49:
LOOP bugs reported by Peter Van Eynde July 25, 2000:
- a: (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.
b: 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"))
but actual specification quoted above says that the actual behavior
is undefined.
+125:
+ (as reported by Gabe Garza on cmucl-help 2001-09-21)
+ (defvar *tmp* 3)
+ (defun test-pred (x y)
+ (eq x y))
+ (defun test-case ()
+ (let* ((x *tmp*)
+ (func (lambda () x)))
+ (print (eq func func))
+ (print (test-pred func func))
+ (delete func (list func))))
+ Now calling (TEST-CASE) gives output
+ NIL
+ NIL
+ (#<FUNCTION {500A9EF9}>)
+ Evidently Python thinks of the lambda as a code transformation so
+ much that it forgets that it's also an object.
+
+126:
+ (reported by Dan Barlow sbcl-devel 2001-09-26)
+ * (defun s () (make-string 10 :initial-element #\Space))
+ S
+ * (s)
+ " "
+ * (compile 's)
+ S
+ NIL
+ NIL
+ * (s)
+ "" <- ten ASCII NULs
+ But other, non-#\Space values of INITIAL-ELEMENT work OK.
+
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
-(Note: At some point, the pure interpreter (actually a semi-pure
-interpreter aka "the IR1 interpreter") will probably go away, replaced
-by constructs like
- (DEFUN EVAL (X) (FUNCALL (COMPILE NIL (LAMBDA ..)))))
-and at that time these bugs should either go away automatically or
-become more tractable to fix. Until then, they'll probably remain,
-since some of them aren't considered urgent, and the rest are too hard
-to fix as long as so many special cases remain. After the IR1
-interpreter goes away is also the preferred time to start
-systematically exterminating cases where debugging functionality
-(backtrace, breakpoint, etc.) breaks down, since getting rid of the
-IR1 interpreter will reduce the number of special cases we need to
-support.)
-
-IR1-1:
- 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. (Later attempting to funcall the
- value does cause an error.)
-
-IR1-2:
- COMPILED-FUNCTION-P bogusly reports T for interpreted functions:
- * (DEFUN FOO (X) (- 12 X))
- FOO
- * (COMPILED-FUNCTION-P #'FOO)
- T
-
-IR1-3:
- Executing
- (DEFVAR *SUPPRESS-P* T)
- (EVAL '(UNLESS *SUPPRESS-P*
- (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- (FORMAT T "surprise!"))))
- prints "surprise!". Probably the entire EVAL-WHEN mechanism ought to be
- rewritten from scratch to conform to the ANSI definition, abandoning
- the *ALREADY-EVALED-THIS* hack which is used in sbcl-0.6.8.9 (and
- in the original CMU CL source, too). This should be easier to do --
- though still nontrivial -- once the various IR1 interpreter special
- cases are gone.
-
-IR1-3a:
- EVAL-WHEN's idea of what's a toplevel form is even more screwed up
- than the example in IR1-3 would suggest, since COMPILE-FILE and
- COMPILE both print both "right now!" messages when compiling the
- following code,
- (LAMBDA (X)
- (COND (X
- (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- (PRINT "yes! right now!"))
- "yes!")
- (T
- (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- (PRINT "no! right now!"))
- "no!")))
- and while EVAL doesn't print the "right now!" messages, the first
- FUNCALL on the value returned by EVAL causes both of them to be printed.
+(Now that the IR1 interpreter has gone away, these should be
+relatively straightforward to fix.)
IR1-4:
The system accepts DECLAIM in most places where DECLARE would be
changes in sbcl-0.7.0 relative to sbcl-0.6.13:
* incompatible change: The default fasl file extension has changed
to ".fasl", for all architectures. (No longer ".x86f" and ".axpf".)
+* The EVAL-WHEN code has been rewritten to be ANSI-compliant, and
+ various related bugs (IR1-1, IR1-2, IR1-3, IR1-3a) have gone away.
+ Since the code is newer, there might still be some new bugs
+ (though not as many as before Martin Atzmueller's fixes:-). But
+ hopefully any remaining bugs will be simpler, less fundamental,
+ and more fixable then the bugs in the old IR1 interpreter code.
+* The IR1 interpreter, byte compiler, and byte interpreter are gone.
+ It's long been my plan to remove the IR1 interpreter while making
+ EVAL-WHEN ANSI-compliant. It turned out that a cascade of changes
+ caused by EVAL-WHEN ANSIness would have required fairly simple
+ changes to the byte compiler; except they turned out to be quite
+ difficult. This, plus the new familiarity with the byte compiler
+ in general that I picked up as I worked on this specific problem,
+ reduced my opinion of its maintainability enough that I deleted it
+ instead of trying to fix it.
* There are new compiler optimizations for various functions: FIND,
POSITION, FIND-IF, POSITION-IF, FILL, COERCE, TRUNCATE, FLOOR, and
CEILING. Mostly these should be transparent, but there's one
it will issue WARNINGs about the type mismatches. It's not clear
how to make the compiler smart enough to fix this in general, but
a workaround is given in the entry for 117 in the BUGS file.
-* The EVAL and EVAL-WHEN code has been largely rewritten, and the
- old CMU CL "IR1 interpreter" has gone away. The new interpreter
- is probably slower and harder to debug than the old one, but
- it's much simpler (several thousand lines of source code simpler)
- and considerably more ANSI-compliant. Bugs
- ?? IR1-3 and
- ?? IR1-3a
- have been fixed. Since the code is newer, there might still be
- some new bugs (though not as many as before Martin Atzmueller's
- fixes:-). But hopefully any remaining bugs will be simpler, less
- fundamental, and more fixable then the bugs in the old IR1
- interpreter code.
* DEFSTRUCT and DEFCLASS have been substantially updated to take
advantage of the new EVAL-WHEN stuff and to clean them up in
- general, and are now more ANSI-compliant in a number of ways. Martin
- Atzmueller is responsible for a lot of this.
+ general, and they are now more ANSI-compliant in a number of
+ ways. Martin Atzmueller is responsible for a lot of this.
* A bug in LOOP operations on hash tables has been fixed, thanks
to a bug report and patch from Alexey Dejneka.
* The default value of *BYTES-CONSED-BETWEEN-GCS* has been
:SB-PROPAGATE-FUN-TYPE are no longer considered to be optional
features. Instead, the code that they used to control is always
built into the system.
+* The support for (DECLAIM (INLINE FOO)) followed by (DEFUN FOO ..) in
+ a non-null lexical environment has been weakened. (It will still
+ compile, but the compiler will be much less determined to inline FOO
+ than it used to be.)
+?? Old operator names in the style DEF-FOO are now deprecated in favor
+ of new corresponding names DEFINE-FOO, for consistency with the
+ naming convention used in the ANSI standard). This mostly affects
+ internal symbols, but a few external symbols like
+ SB-ALIEN:DEF-ALIEN-FUNCTION are also affected.
+* minor incompatible change: DEFINE-ALIEN-FUNCTION (also known by
+ the old deprecated name DEF-ALIEN-FUNCTION) now does DECLAIM FTYPE
+ for the defined function, since declaiming return types involving
+ aliens is (1) annoyingly messy to do by hand and (2) vital
+ to efficient compilation of code which calls such functions (and
+ since people writing calls-to-C code aren't likely to be bothered
+ by implicit assumptions of static typing).
+* The interpreter, EVAL, has been rewritten. Now it calls the
+ native compiler for the difficult cases, where it used to call
+ the old specialized IR1 interpreter code.
* The doc/cmucl/ directory, containing old CMU CL documentation,
- is no longer part of the base system. The files which used to
- be in the doc/cmucl/ directory are now available as
- <ftp://sbcl.sourceforge.net/pub/sbcl/cmucl-docs.tar.bz2>.
-* lots of tidying up internally: renaming things so that names are
- more systematic and consistent, converting C macros to inline
+ is no longer part of the base system. SourceForge has shut down
+ its anonymous FTP service, and with it my original plan for
+ distributing them separately. For now, if you need them you can
+ download an old sbcl source release and get them from there.
+?? The compiler, especially the IR1 phase of the compiler, has been
+ tweaked somewhat to support the new implementation of DEFUN and
+ of the static linking hack used for cold init. In particular,
+ the property of "is externally visible" is now orthogonal to
+ the property of "is optimized/specialized for being called
+ at LOAD time, with no arguments and no argument checking".
+ The old FUNCTIONAL-KIND=:TOP-LEVEL type code which
+ conflated these two properties has been replaced with the
+ FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P flag. This has minor
+ beneficial consequences for the logic of #'CL:COMPILE and other
+ things. Like the rewrite of EVAL, it has also quite possibly
+ introduced some new bugs, but since the new logic is simpler and
+ more orthogonal, hopefully it will be easier to clean up bugs
+ in the new code than it was in the old code.
+* lots of other tidying up internally: renaming things so that names
+ are more systematic and consistent, converting C macros to inline
functions, systematizing indentation, making symbol packaging
more logical, and so forth
-* The fasl file version number changed again, for any number of
- good reasons.
+* The fasl file version number changed again, for about a dozen
+ reasons, some of which are obvious above.
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
;; interpreted /SHOW doesn't work until later in init.
#+sb-show (print "/hello, world!")
+ ;; Until PRINT-OBJECT and other machinery is set up,
+ ;; we want limits on printing to avoid infinite output.
+ (setq *print-length* 10)
+ (setq *print-level* 5)
+
;; Do warm init.
- (let ((*print-length* 10)
- (*print-level* 5))
- #+sb-show (print "/about to LOAD warm.lisp")
- (load "src/cold/warm.lisp"))
+ #+sb-show (print "/about to LOAD warm.lisp")
+ (load "src/cold/warm.lisp")
;; Unintern no-longer-needed stuff before the possible PURIFY
;; in SAVE-LISP-AND-DIE.
#-sb-fluid (sb-impl::!unintern-init-only-stuff)
+ ;; Now that the whole system is built, we don't need to
+ ;; hobble the printer any more.
+ (setq *print-length* nil)
+ (setq *print-level* nil)
+
;; FIXME: Why is it that, at least on x86 sbcl-0.6.12.46,
;; GC :FULL T isn't nearly as effective as PURIFY here?
;; (GC :FULL T gets us down to about 38 Mbytes, but PURIFY
"MULTIPLY-FIXNUMS" "NEGATE-BIGNUM"
"SUBTRACT-BIGNUM" "SXHASH-BIGNUM"))
+ ;; FIXME: byte compiler/interpreter to go away completely
+ #|
#s(sb-cold:package-data
:name "SB!BYTECODE"
:doc "private: stuff related to the bytecode interpreter"
:use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
:export ())
+ |#
#s(sb-cold:package-data
:name "SB!C"
"CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32"
"CLOSURE-INIT" "CLOSURE-REF"
"CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
- "COMPILER-ERROR"
+ "COMPILE-LAMBDA-FOR-DEFUN"
+ "%COMPILER-DEFUN" "COMPILER-ERROR"
"COMPONENT" "COMPONENT-HEADER-LENGTH"
"COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUNCTION"
"COMPUTE-OLD-NFP" "COPY-MORE-ARG"
"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"
+ "FORCE-TN-TO-STACK"
+ "GET-VECTOR-SUBTYPE"
+ "HALT"
+ "IF-EQ" "INLINE-SYNTACTIC-CLOSURE-LAMBDA"
+ "INSTANCE-REF" "INSTANCE-SET"
"IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
- "IR2-ENVIRONMENT-NUMBER-STACK-P" "KNOWN-CALL-LOCAL"
- "KNOWN-RETURN" "LOCATION=" "LTN-ANNOTATE"
+ "IR2-ENVIRONMENT-NUMBER-STACK-P"
+ "KNOWN-CALL-LOCAL" "KNOWN-RETURN"
+ "LAMBDA-INDEPENDENT-OF-LEXENV-P"
+ "LAMBDA-WITH-LEXENV" "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"
"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"
+ "MULTIPLE-CALL-VARIABLE"
+ "NLX-ENTRY" "NLX-ENTRY-MULTIPLE"
"NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START"
"NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE"
"PARSE-EVAL-WHEN-SITUATIONS"
"+FASL-FILE-VERSION+"
"FASL-DUMP-BYTE-COMPONENT"
"FASL-DUMP-COLD-LOAD-FORM" "FASL-DUMP-COMPONENT"
+ "FASL-DUMP-COLD-FSET"
"FASL-DUMP-LOAD-TIME-VALUE" "FASL-DUMP-LOAD-TIME-VALUE-LAMBDA"
"FASL-DUMP-SOURCE-INFO" "FASL-DUMP-TOP-LEVEL-LAMBDA-CALL"
"FASL-NOTE-HANDLE-FOR-CONSTANT"
- "FASL-OUTPUT" "FASL-OUTPUT-P" "FASL-OUTPUT-STREAM"
+ "FASL-OUTPUT" "FASL-OUTPUT-P"
+ "FASL-OUTPUT-ENTRY-TABLE" "FASL-OUTPUT-STREAM"
"FASL-VALIDATE-STRUCTURE"
"*!LOAD-TIME-VALUES*"
"LOAD-TYPE-PREDICATE"
;; ..and macros..
"COLLECT"
"DO-ANONYMOUS" "DOHASH" "DOVECTOR"
+ "NAMED-LAMBDA"
"NAMED-LET"
"ONCE-ONLY"
"DEFENUM"
"UNIX-ENVIRONMENT-CMUCL-FROM-SBCL"
"UNIX-ENVIRONMENT-SBCL-FROM-CMUCL"
- ;; a sort of quasi unbound tag for use in hash tables
+ ;; a sort of quasi-unbound tag for use in hash tables
"+EMPTY-HT-SLOT+"
;; low-level i/o stuff
"PREPARE-FOR-FAST-READ-BYTE"
"PREPARE-FOR-FAST-READ-CHAR"
- ;; 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")))
+ ;; hackery to help set up for cold init
+ "!BEGIN-COLLECTING-COLD-INIT-FORMS"
+ "!COLD-INIT-FORMS"
+ "COLD-FSET"
+ "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS"))
#s(sb-cold:package-data
:name "SB!ITERATE"
"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"
"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-BIT-VECTOR" "COERCE-TO-FUNCTION" "COERCE-TO-LEXENV"
"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-DOUBLE-FLOAT-P"
"COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P"
"COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P" "COMPLEX-VECTOR-P"
"COMPOUND-TYPE" "COMPOUND-TYPE-P" "COMPOUND-TYPE-TYPES"
"DOUBLE-FLOAT-SIGNIFICAND"
"DOUBLE-FLOAT-P" "FLOAT-WAIT"
"DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
- "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS"
"ERROR-NUMBER-OR-LOSE"
"FAILED-%WITH-ARRAY-DATA"
"FDEFINITION-OBJECT"
"INVOKE-MACROEXPAND-HOOK"
"DEFAULT-STRUCTURE-PRINT"
"LAYOUT" "LAYOUT-LENGTH"
- "LAMBDA-WITH-ENVIRONMENT" "LAYOUT-PURE" "DSD-RAW-TYPE"
+ "LAYOUT-PURE" "DSD-RAW-TYPE"
"DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE"
"DD-COPIER" "UNDEFINE-FUNCTION-NAME" "DD-TYPE"
"CLASS-STATE" "INSTANCE"
;;; (Are they used in anything time-critical, or just the debugger?)
(defun context-register (context index)
(declare (type (alien (* os-context-t)) context))
- (deref (context-register-addr context index)))
+ (deref (the (alien (* unsigned-long))
+ (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))
+ (declare (type (alien (* os-context-t)) context))
+ (setf (deref (the (alien (* unsigned-long))
+ (context-register-addr context index)))
+ new))
;;; This is like CONTEXT-REGISTER, but returns the value of a float
;;; register. FORMAT is the type of float to return.
;;; to replicate)
(defun internal-error-arguments (context)
(declare (type (alien (* os-context-t)) context))
- (sb!int::/show0 "entering INTERNAL-ERROR-ARGUMENTS")
(let ((pc (context-pc context)))
(declare (type system-area-pointer pc))
;; pc is a SAP pointing at - or actually, shortly after -
(defun vector-push-extend (new-element
vector
&optional
- (extension nil extension-p))
- #!+sb-doc
- "This is like VECTOR-PUSH except that if the fill pointer gets too
- large, VECTOR is extended to allow the push to work."
- (declare (type vector vector))
- (let ((old-fill-pointer (fill-pointer vector)))
- (declare (type index old-fill-pointer))
- (when (= old-fill-pointer (%array-available-elements vector))
- (adjust-array vector (+ old-fill-pointer
- (if extension-p
- (the (integer 1 #.most-positive-fixnum)
- extension)
- (1+ old-fill-pointer)))))
- (setf (%array-fill-pointer vector)
- (1+ old-fill-pointer))
- ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
- ;; saves some time.
- (with-array-data ((v vector) (i old-fill-pointer) (end)
- :force-inline t)
- (declare (ignore end) (optimize (safety 0)))
- (if (simple-vector-p v) ; if common special case
- (setf (aref v i) new-element)
- (setf (aref v i) new-element)))
- old-fill-pointer))
-
-(defun vector-push-extend (new-element
- vector
- &optional
(extension (1+ (length vector))))
(declare (vector vector) (fixnum extension))
(let ((fill-pointer (fill-pointer vector)))
(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."
+ "Decrease the fill pointer by 1 and return the element pointed to by the
+ new fill pointer."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
initial-contents fill-pointer
displaced-to displaced-index-offset)
#!+sb-doc
- "Adjusts the Array's dimensions to the given Dimensions and stuff."
+ "Adjust 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)))
(in-package "SB!IMPL")
+(/show0 "entering backq.lisp")
+
;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
;;;
;;; |`,|: [a] => a
(defvar *bq-dot-flag* '(|,.|))
(defvar *bq-vector-flag* '(|bqv|))
+(/show0 "backq.lisp 50")
+
;;; the actual character macro
(defun backquote-macro (stream ignore)
(declare (ignore ignore))
(%reader-error stream ",. after backquote in ~S" thing))
(values (backquotify-1 flag thing) 'list))))
+(/show0 "backq.lisp 64")
+
(defun comma-macro (stream ignore)
(declare (ignore ignore))
(unless (> *backquote-count* 0)
(cons *bq-comma-flag* (read stream t nil t))))
'list)))
+(/show0 "backq.lisp 83")
+
;;; This does the expansion from table 2.
(defun backquotify (stream code)
(cond ((atom code)
(values 'list*
(list a (backquotify-1 dflag d)))))))))))
+(/show0 "backq.lisp 139")
+
;;; This handles the <hair> cases.
(defun comma (code)
(cond ((atom code)
(values 'list* (cdr code)))
(t (values *bq-comma-flag* code))))
+(/show0 "backq.lisp 157")
+
;;; This handles table 1.
(defun backquotify-1 (flag thing)
(cond ((or (eq flag *bq-comma-flag*)
\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.
+(/show0 "backq.lisp 184")
+
+;;; Define synonyms for the lisp functions we use, so that by using
+;;; them, the 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
(def-frob backq-nconc nconc)
(def-frob backq-cons cons))
+(/show0 "backq.lisp 204")
+
(defun backq-vector (list)
(declare (list list))
(coerce list 'simple-vector))
\f
;;;; initialization
+(/show0 "backq.lisp 212")
+
;;; 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.)
+;;; 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)
+
+(/show0 "done with backq.lisp")
(defun two-arg-string< (x y) (string= x y))
(defun two-arg-string> (x y) (string= x y))
\f
-;;;; miscellaneous primitive stubs
-
-(macrolet ((def-frob (name &optional (args '(x)))
- `(defun ,name ,args (,name ,@args))))
- (def-frob %code-code-size)
- (def-frob %code-debug-info)
- (def-frob %code-entry-points)
- (def-frob %funcallable-instance-function)
- (def-frob %funcallable-instance-layout)
- (def-frob %funcallable-instance-lexenv)
- (def-frob %function-next)
- (def-frob %function-self)
- (def-frob %set-funcallable-instance-function (fin new-val)))
-\f
;;;; funny functions
;;; (used both by the byte interpreter and by the IR1 interpreter)
;;; messing up --noprogrammer mode (which works by setting
;;; *DEBUGGER-HOOK*)
(defun %break (what &optional (datum "break") &rest arguments)
- ;; FIXME: Do we really want INFINITE-ERROR-PROTECT in BREAKish stuff?
(sb!kernel:infinite-error-protect
(with-simple-restart (continue "Return from ~S." what)
(let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
(and (typep x 'simple-array)
(= 1 (array-rank x))))
-;;; Genesis needs these at cross-compile time. The target
+;;; 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.
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
+ (/show0 "entering TOP-FRAME")
(multiple-value-bind (fp pc) (%caller-frame-and-pc)
(possibly-an-interpreted-frame
(compute-calling-frame (descriptor-sap fp)
;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
+ (/show0 "entering FRAME-DOWN")
;; We have to access the old-fp and return-pc out of frame and pass
;; them to COMPUTE-CALLING-FRAME.
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
(let* ((real (frame-real-frame frame))
(debug-fun (frame-debug-function real)))
+ (/show0 "in DOWN :UNPARSED case")
(setf (frame-%down frame)
(etypecase debug-fun
(compiled-debug-function
;; new SBCL code, not ambitious enough to do anything tricky like
;; hiding the byte interpreter when debugging
(declare (ignore up-frame))
+ (/show "doing trivial POSSIBLY-AN-INTERPRETED-FRAME")
frame
- ;; old CMU CL code to hide IR1 interpreter when debugging
+ ;; old CMU CL code to hide IR1 interpreter when debugging:
;;
;;(if (or (not frame)
;; (not (eq (debug-function-name (frame-debug-function
#!+x86
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
+ (/show0 "entering COMPUTE-CALLING-FRAME")
(when (cstack-pointer-valid-p caller)
+ (/show0 "in WHEN")
;; 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.
- (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))
- (aver code)))
- (t
- ;; not escaped
- (multiple-value-setq (pc-offset code)
- (compute-lra-data-from-pc ra))
- (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)))))
+ (/show0 "at COND")
+ (cond (code
+ (/show0 "in CODE clause")
+ ;; If it's escaped it may be a function end breakpoint trap.
+ (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))
+ (aver code)))
+ (t
+ (/show0 "in T clause")
+ ;; not escaped
+ (multiple-value-setq (pc-offset code)
+ (compute-lra-data-from-pc ra))
+ (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)))))
+ (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+ (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 find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
+ (/show0 "entering FIND-ESCAPED-FRAME")
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
(sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil)
- :extern))
+ ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
+ (/show0 "at head of WITH-ALIEN")
(let ((context (sb!alien:deref lisp-interrupt-contexts index)))
+ (/show0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
(without-gcing
+ (/show0 "in WITHOUT-GCING")
(let* ((component-ptr (component-ptr-from-pc
(sb!vm:context-pc context)))
(code (unless (sap= component-ptr (int-sap #x0))
(component-from-component-ptr component-ptr))))
+ (/show0 "got CODE")
(when (null code)
(return (values code 0 context)))
(let* ((code-header-len (* (get-header-data code)
(- (get-lisp-obj-address code)
sb!vm:other-pointer-type)
code-header-len)))
+ (/show "got PC-OFFSET")
(unless (<= 0 pc-offset
(* (code-header-ref code sb!vm:code-code-size-slot)
sb!vm:word-bytes))
;; FIXME: Should this be WARN or ERROR or what?
(format t "** pc-offset ~S not in code obj ~S?~%"
pc-offset code))
+ (/show0 "returning from FIND-ESCAPED-FRAME")
(return
(values code pc-offset context))))))))))
(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")
+ ;; package name string here. It would be
+ ;; nicer 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..
;; 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")))))
+ (or (find-package "SB-DEBUG")
+ (find-package "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))
+ (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)))
(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))
+ (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)
(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)
+;;;; DEFUN
+
+;;; Should we save the inline expansion of the function named NAME?
+(defun inline-function-name-p (name)
+ (or
+ ;; the normal reason for saving the inline expansion
+ (info :function :inlinep name)
+ ;; another reason for saving the inline expansion: If the
+ ;; ANSI-recommended idiom
+ ;; (DECLAIM (INLINE FOO))
+ ;; (DEFUN FOO ..)
+ ;; (DECLAIM (NOTINLINE FOO))
+ ;; has been used, and then we later do another
+ ;; (DEFUN FOO ..)
+ ;; without a preceding
+ ;; (DECLAIM (INLINE FOO))
+ ;; what should we do with the old inline expansion? Overwriting it
+ ;; with the new definition seems like the only unsurprising choice.
+ (info :function :inline-expansion name)))
+
+;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can
+;;; make a reasonably readable definition of DEFUN.
+(defmacro-mundanely defun (&environment env name args &body body)
+ "Define a function at top level."
+ #+sb-xc-host
+ (unless (symbol-package (function-name-block-name name))
+ (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name))
(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 we're built as a cross-compiler, the DEF is a function
- ;; implemented by the cross-compilation host, which is opaque to us.
- ;; Similarly, other things like FDEFINITION or DOCUMENTATION either
- ;; aren't ours to mess with or are meaningless to mess with. Thus,
- ;; we punt.
- #+sb-xc-host (declare (ignore def doc))
- #-sb-xc-host
- (progn
- (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))))
- ;; Other stuff remains meaningful whether we're cross-compiling or
- ;; native compiling.
- (become-defined-function-name name)
- (when (or inline-expansion
- (info :function :inline-expansion name))
- (setf (info :function :inline-expansion name)
- inline-expansion))
- ;; Voila.
+ (let* ((lambda `(lambda ,args
+ ,@decls
+ (block ,(function-name-block-name name)
+ ,@forms)))
+ (want-to-inline )
+ (inline-lambda
+ (cond (;; Does the user not even want to inline?
+ (not (inline-function-name-p name))
+ nil)
+ (;; Does inlining look too hairy to handle?
+ (not (sb!c:lambda-independent-of-lexenv-p lambda env))
+ (sb!c:maybe-compiler-note
+ "lexical environment too hairy, can't inline DEFUN ~S"
+ name)
+ nil)
+ (t
+ ;; FIXME: The only reason that we return
+ ;; LAMBDA-WITH-LEXENV instead of returning bare
+ ;; LAMBDA is to avoid modifying downstream code
+ ;; which expects LAMBDA-WITH-LEXENV. But the code
+ ;; here is the only code which feeds into the
+ ;; downstream code, and the generality of the
+ ;; interface is no longer used, so it'd make sense
+ ;; to simplify the interface instead of using the
+ ;; old general LAMBDA-WITH-LEXENV interface in this
+ ;; simplified way.
+ `(sb!c:lambda-with-lexenv
+ nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS
+ ,@(rest lambda))))))
+ `(progn
+
+ ;; In cross-compilation of toplevel DEFUNs, we arrange
+ ;; for the LAMBDA to be statically linked by GENESIS.
+ #+sb-xc-host
+ (cold-fset ,name ,lambda)
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (sb!c:%compiler-defun ',name ',inline-lambda))
+
+ (%defun ',name
+ ;; In normal compilation (not for cold load) this is
+ ;; where the compiled LAMBDA first appears. In
+ ;; cross-compilation, we manipulate the
+ ;; previously-statically-linked LAMBDA here.
+ #-sb-xc-host ,lambda
+ #+sb-xc-host (fdefinition ',name)
+ ,doc)))))
+#-sb-xc-host
+(defun %defun (name def doc)
+ (declare (type function def))
+ (declare (type (or null simple-string doc)))
+ (/show0 "entering %DEFUN, name (or block name) = ..")
+ (/primitive-print (symbol-name (function-name-block-name name)))
+ (aver (legal-function-name-p name))
+ (when (fboundp name)
+ (/show0 "redefining NAME")
+ (style-warn "redefining ~S in DEFUN" name))
+ (/show0 "setting FDEFINITION")
+ (setf (sb!xc:fdefinition name) def)
+ (when doc
+ ;; FIXME: This should use shared SETF-name-parsing logic.
+ (/show0 "setting FDOCUMENTATION")
+ (if (and (consp name) (eq (first name) 'setf))
+ (setf (fdocumentation (second name) 'setf) doc)
+ (setf (fdocumentation (the symbol name) 'function) doc)))
+ (/show0 "leaving %DEFUN")
name)
-;;; FIXME: Now that the IR1 interpreter is going away and EVAL-WHEN is
-;;; becoming ANSI-compliant, it should be possible to merge this and
-;;; DEF-IR1-TRANSLATOR %DEFUN into a single DEFUN. (And does %%DEFUN
-;;; merge into that too? dunno..)
-(defun sb!c::%defun (name def doc source)
- (declare (ignore source))
- (flet ((set-type-info-from-def ()
- (setf (info :function :type name)
- #-sb-xc-host (extract-function-type def)
- ;; When we're built as a cross-compiler, the DEF is
- ;; a function implemented by the cross-compilation
- ;; host, which is opaque to us, so we have to punt here.
- #+sb-xc-host *universal-function-type*)))
- (ecase (info :function :where-from name)
- (:assumed
- (setf (info :function :where-from name) :defined)
- (set-type-info-from-def)
- (when (info :function :assumed-type name)
- (setf (info :function :assumed-type name) nil)))
- (:declared)
- (:defined
- (set-type-info-from-def)
- ;; We shouldn't need to clear this here because it should be
- ;; clear already (having been cleared when the last definition
- ;; was processed).
- (aver (null (info :function :assumed-type name))))))
- (sb!c::%%defun name def doc))
\f
;;;; DEFVAR and DEFPARAMETER
;; form, we introduce a gratuitous binding of the variable to NIL
;; without 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.
+ ;; since 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)
;;; takes effect in :LOAD-TOPLEVEL or :EXECUTE situations.
(def!macro defmacro-mundanely (name lambda-list &body body)
(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)
+ (environment (gensym "ENVIRONMENT-")))
+ (multiple-value-bind (new-body local-decs doc)
+ (parse-defmacro lambda-list whole body name 'defmacro
+ :environment environment)
`(progn
(setf (sb!xc:macro-function ',name)
(lambda (,whole ,environment)
\f
;;;; getting LAYOUTs
-;;; Return the compiler layout for Name. (The class referred to by
+;;; 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)))
(let* ((name (dd-name dd)))
(collect ((res))
(dolist (slot (dd-slots dd))
- (let ((stype (dsd-type slot))
+ (let ((slot-type (dsd-type slot))
(accessor-name (dsd-accessor-name slot))
(argname (gensym "ARG"))
(nvname (gensym "NEW-VALUE-")))
(when (and accessor-name
(not (eq accessor-name '%instance-ref)))
(res `(declaim (inline ,accessor-name)))
- (res `(declaim (ftype (function (,name) ,stype) ,accessor-name)))
+ (res `(declaim (ftype (function (,name) ,slot-type)
+ ,accessor-name)))
(res `(defun ,accessor-name (,argname)
- (truly-the ,stype (,accessor ,data ,offset))))
+ ;; Note: The DECLARE here might seem redundant
+ ;; with the DECLAIM FTYPE above, but it's not:
+ ;; If we're not at toplevel, the PROCLAIM inside
+ ;; the DECLAIM doesn't get executed until after
+ ;; this function is compiled.
+ (declare (type ,name ,argname))
+ (truly-the ,slot-type (,accessor ,data ,offset))))
(unless (dsd-read-only slot)
(res `(declaim (inline (setf ,accessor-name))))
- (res `(declaim (ftype (function (,stype ,name) ,stype)
+ (res `(declaim (ftype (function (,slot-type ,name) ,slot-type)
(setf ,accessor-name))))
;; 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 ,accessor-name) (,nvname ,argname)
+ (declare (type ,name ,argname))
(setf (,accessor ,data ,offset) ,nvname)
,nvname)))))))
(res))))
(collect ((stuff))
(let ((ltype (dd-lisp-type defstruct)))
(dolist (slot (dd-slots defstruct))
- (let ((name (dsd-accessor slot))
+ (let ((name (dsd-accessor-name slot))
(index (dsd-index slot))
(slot-type `(and ,(dsd-type slot)
,(dd-element-type defstruct))))
(%describe-function-name name s (%function-type x))))
(%describe-compiled-from (sb-kernel:function-code-header x) s))
+;;; FIXME: byte compiler to go away completely
+#|
(defun %describe-function-byte-compiled (x s kind name)
(declare (type stream s))
(let ((name (or name (sb-c::byte-function-name x))))
(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
(%describe-function-compiled x s kind name))
(#.sb-vm:funcallable-instance-header-type
(typecase x
+ ;; FIXME: byte compiler to go away completely
+ #|
(sb-kernel:byte-function
(%describe-function-byte-compiled x s kind name))
(sb-kernel:byte-closure
(let ((data (byte-closure-data x)))
(dotimes (i (length data))
(format s "~@:_~S: ~S" i (svref data i))))))
+ |#
(standard-generic-function
;; There should be a special method for this case; we'll
;; delegate to that.
;; a constant as long as the new value is EQL to the old
;; value.)
))
+
+;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
+;;; assignment. That way things like
+;;; (FLET ((FROB (X) ..))
+;;; (DEFUN FOO (X Y) (FROB X) ..)
+;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
+;;; can still "work" for cold init: they don't do magical static
+;;; linking the way that true toplevel DEFUNs do, but at least they do
+;;; the linking eventually, so as long as #'FOO and #'BAR aren't
+;;; needed until "cold toplevel forms" have executed, it's OK.
+(defmacro cold-fset (name lambda)
+ (style-warn
+ "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
+(SETF FDEFINITION)~:@>"
+ name)
+ `(setf (fdefinition ',name) ,lambda))
\f
;;;; ONCE-ONLY
;;;;
;;;
;;; 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)
- "-")))
+(defmacro defprinter ((name
+ &key
+ (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-"))
+ identity)
&rest slot-descs)
(let ((first? t)
maybe-print-space
`(def!method print-object ((structure ,name) ,stream)
;; FIXME: should probably be byte-compiled
(pprint-logical-block (,stream nil)
- (print-unreadable-object (structure ,stream :type t)
+ (print-unreadable-object (structure
+ ,stream
+ :type t
+ :identity ,identity)
,@(nreverse reversed-prints))))))
\f
;;;; etc.
;;; This value should be incremented when the system changes in such
;;; a way that it will no longer work reliably with old fasl files.
-(defconstant +fasl-file-version+ 16)
+(defconstant +fasl-file-version+ 17)
;;; 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
;;; 14 = sbcl-0.6.12.29 removed more elements from *STATIC-SYMBOLS*
;;; 15 = sbcl-0.6.12.33 changed the layout of STREAM
;;; 16 = sbcl-0.pre7.15 changed the layout of PRETTY-STREAM
+;;; 17 = sbcl-0.pre7.38 (merging many changes accumulated in
+;;; the sbcl-0.pre7.37.flaky5.* branch back into the main branch)
+;;; got rid of byte compiler, byte interpreter, and IR1
+;;; interpreter, changed %DEFUN and DEFSTRUCT, changed the
+;;; meaning of FOP-FSET, and changed the layouts of various
+;;; internal compiler structures (e.g. DEFSTRUCT CLAMBDA)
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
;; 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))))
+ ;; 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
+ (coerce-to-lexenv environment)))
(t
(expand-or-get-setf-inverse form environment)))))
(funcall (compile (gensym "EVAL-TMPFUN-")
`(lambda ()
- ;; SPEED=0,DEBUG=1 => byte-compile
- (declare (optimize (speed 0) (debug 1)))
+ ;; The user can reasonably expect that the
+ ;; interpreter will be safe.
+ (declare (optimize (safety 3)))
- ;; Other than that, basically we care about
- ;; compilation speed, compilation speed, and
- ;; compilation speed. (There are cases where
- ;; the user wants something else, but we don't
- ;; know enough to guess that; and if he is
- ;; unhappy about our guessed emphasis, he
- ;; should explicitly compile his code, with
- ;; explicit declarations to tell us what to
- ;; emphasize.)
- (declare (optimize (space 1) (safety 1)))
- (declare (optimize (compilation-speed 3)))
+ ;; It's also good if the interpreter doesn't
+ ;; spend too long thinking about each input
+ ;; form, since if the user'd wanted the
+ ;; tradeoff to favor quality of compiled code
+ ;; over compilation speed, he'd've explicitly
+ ;; asked for compilation.
+ (declare (optimize (compilation-speed 2)))
+
+ ;; Other properties are relatively unimportant.
+ (declare (optimize (speed 1) (debug 1) (space 1)))
,expr))))
(t
exp))))
-;;; 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.
-;;;
-;;; 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)
- (declare (type function 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))))
+ "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
+ DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
+ to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition
+ might have been enclosed in some non-null lexical environment, and
+ NAME is some name (for debugging only) or NIL if there is no name."
+ (declare (type function 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))))
\f
;;; miscellaneous full function definitions of things which are
;;; ordinarily handled magically by the compiler
(/show0 "filesys.lisp 498")
-;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
-
-(defmacro enumerate-matches ((var pathname &optional result
- &key (verify-existence t)
- (follow-links t))
- &body body)
- (let ((body-name (gensym "ENUMERATE-MATCHES-BODY-FUN-")))
- `(block nil
- (flet ((,body-name (,var)
- ,@body))
- (declare (dynamic-extent ,body-name))
- (%enumerate-matches (pathname ,pathname)
- ,verify-existence
- ,follow-links
- #',body-name)
- ,result))))
+(defmacro !enumerate-matches ((var pathname &optional result
+ &key (verify-existence t)
+ (follow-links t))
+ &body body)
+ `(block nil
+ (%enumerate-matches (pathname ,pathname)
+ ,verify-existence
+ ,follow-links
+ (lambda (,var) ,@body))
+ ,result))
(/show0 "filesys.lisp 500")
;; Otherwise, the ordinary rules apply.
(let* ((namestring (physicalize-pathname (pathname pathname-spec)))
(matches nil)) ; an accumulator for actual matches
- (enumerate-matches (match namestring nil :verify-existence for-input)
+ (!enumerate-matches (match namestring nil :verify-existence for-input)
(push match matches))
(case (length matches)
(0 nil)
(make-pathname :name :wild
:type :wild
:version :wild))))
- (enumerate-matches (match merged-pathname)
+ (!enumerate-matches (match merged-pathname)
(let ((*ignore-wildcards* t))
(push (truename (if (eq (sb!unix:unix-file-kind match) :directory)
(concatenate 'string match "/")
(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))
+ ;; Ordinary, not-for-cold-load code shouldn't need to mess with this
+ ;; at all, since it's only used as part of the conspiracy between
+ ;; the cross-compiler and GENESIS to statically link FDEFINITIONs
+ ;; for cold init.
+ (warn "~@<FOP-FSET seen in ordinary load (not cold load) -- quite strange! ~
+If you didn't do something strange to cause this, please report it as a ~
+bug.~:@>")
+ ;; Unlike CMU CL, we don't treat this as a no-op in ordinary code.
+ ;; If the user (or, more likely, developer) is trying to reload
+ ;; compiled-for-cold-load code into a warm SBCL, we'll do a warm
+ ;; assignment. (This is partly for abstract tidiness, since the warm
+ ;; assignment is the closest analogy to what happens at cold load,
+ ;; and partly because otherwise our compiled-for-cold-load code will
+ ;; fail, since in SBCL things like compiled-for-cold-load %DEFUN
+ ;; depend more strongly than in CMU CL on FOP-FSET actually doing
+ ;; something.)
+ (let ((fn (pop-stack))
+ (name (pop-stack)))
+ (setf (fdefinition name) fn)))
;;; Modify a slot in a Constants object.
(define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141)
(format t "~S defined~%" fun))
fun)))
+;;; FIXME: byte compiler to be completely deleted
+#|
(define-fop (fop-make-byte-compiled-function 143)
(let* ((size (read-arg 1))
(layout (pop-stack))
(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
nil)))))
(defun find-interrupted-name ()
+ (/show0 "entering FIND-INTERRUPTED-NAME")
(if *finding-name*
(values "<error finding interrupted name -- already finding name>" nil)
(handler-case
(let ((*finding-name* t))
+ (/show0 "in ordinary case")
(do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
((null frame)
+ (/show0 "null frame")
(values "<error finding interrupted name -- null frame>" nil))
+ (/show0 "at head of DO loop")
(when (and (sb!di::compiled-frame-p frame)
(sb!di::compiled-frame-escaped frame))
(sb!di:flush-frames-above frame)
+ (/show0 "returning from within DO loop")
(return (values (sb!di:debug-function-name
(sb!di:frame-debug-function frame))
frame)))))
(error ()
+ (/show0 "trapped ERROR")
(values "<error finding interrupted name -- trapped error>" nil))
(sb!di:debug-condition ()
+ (/show0 "trapped 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))
+ (declare (type system-area-pointer context))
+ (declare (ignore continuable))
(/show0 "entering INTERNAL-ERROR, CONTEXT=..")
(/hexstr context)
(infinite-error-protect
- (let ((context (locally
- (declare (optimize (inhibit-warnings 3)))
- (sb!alien:sap-alien context (* os-context-t)))))
+ (/show0 "about to bind ALIEN-CONTEXT")
+ (let ((alien-context (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien context (* os-context-t)))))
+ (/show0 "about to bind ERROR-NUMBER and ARGUMENTS")
(multiple-value-bind (error-number arguments)
- (sb!vm:internal-error-arguments context)
+ (sb!vm:internal-error-arguments alien-context)
+ (/show0 "back from INTERNAL-ERROR-ARGUMENTS, ERROR-NUMBER=..")
+ (/hexstr error-number)
+ (/show0 "ARGUMENTS=..")
+ (/hexstr arguments)
(multiple-value-bind (name sb!debug:*stack-top-hint*)
(find-interrupted-name)
- (let ((fp (int-sap (sb!vm:context-register context
+ (/show0 "back from FIND-INTERRUPTED-NAME")
+ (let ((fp (int-sap (sb!vm:context-register alien-context
sb!vm::cfp-offset)))
(handler (and (< -1 error-number (length *internal-errors*))
(svref *internal-errors* error-number))))
(list error-number
(mapcar #'(lambda (sc-offset)
(sb!di::sub-access-debug-var-slot
- fp sc-offset context))
+ fp sc-offset alien-context))
arguments))))
((not (functionp handler))
(error 'simple-error
handler
(mapcar #'(lambda (sc-offset)
(sb!di::sub-access-debug-var-slot
- fp sc-offset context))
+ fp sc-offset alien-context))
arguments))))
(t
- (funcall handler name fp context arguments)))))))))
+ (funcall handler name fp alien-context arguments)))))))))
(type=-set (intersection-type-types type1)
(intersection-type-types type2)))
-(flet ((intersection-complex-subtypep-arg1 (type1 type2)
- (any/type (swapped-args-fun #'csubtypep)
- type2
- (intersection-type-types type1))))
- (!define-type-method (intersection :simple-subtypep) (type1 type2)
- (every/type #'intersection-complex-subtypep-arg1
- type1
- (intersection-type-types type2)))
- (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
- (intersection-complex-subtypep-arg1 type1 type2)))
+(defun %intersection-complex-subtypep-arg1 (type1 type2)
+ (any/type (swapped-args-fun #'csubtypep)
+ type2
+ (intersection-type-types type1)))
+
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (every/type #'%intersection-complex-subtypep-arg1
+ type1
+ (intersection-type-types type2)))
+
+(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+ (%intersection-complex-subtypep-arg1 type1 type2))
(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
(every/type #'csubtypep type1 (intersection-type-types type2)))
:low low
:high high))))
\f
-(!defun-from-collected-cold-init-forms !late-type-cold-init)
+(locally
+ ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type
+ ;; checking for declarations in structure accessors. Otherwise we
+ ;; can get caught in a chicken-and-egg bootstrapping problem, whose
+ ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal
+ ;; instruction trap. I haven't tracked it down, but I'm guessing it
+ ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set
+ ;; yet. -- WHN
+ (declare (optimize (safety 0)))
+ (!defun-from-collected-cold-init-forms !late-type-cold-init))
(/show0 "late-type.lisp end of file")
;;;; -- 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
+ tree-equal nth %setnth nthcdr last make-list append
+ nconc 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
+ set-exclusive-or nset-exclusive-or subsetp acons 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))
list))))
(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."
+ "Return 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))
(defun rplaca (x y)
#!+sb-doc
- "Changes the car of x to y and returns the new x."
+ "Change the CAR of X to Y and return the new X."
(rplaca x y))
(defun rplacd (x y)
#!+sb-doc
- "Changes the cdr of x to y and returns the new x."
+ "Change the CDR of X to Y and return the new X."
(rplacd x y))
;;; The following are for use by SETF.
(defun %rplacd (x val) (rplacd x val) val)
+;;; Set the Nth element of LIST to NEWVAL.
(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)
(defun identity (thing)
#!+sb-doc
- "Returns what was passed to it."
+ "This function simply returns what was passed to it."
thing)
(defun complement (function)
#!+sb-doc
- "Builds a new function that returns T whenever FUNCTION returns NIL and
+ "Return a new function that returns T whenever FUNCTION returns NIL and
NIL whenever FUNCTION returns non-NIL."
(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
&rest more-args)
(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."
+ "Returns the first cons in ALIST whose car does not satisfy 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."
+ "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))))
;; in what it sends and liberal in what it
;; accepts" by doing the defaulting itself.
;; -- WHN 19991128
- (or env (make-null-lexenv)))
+ (coerce-to-lexenv env))
t)
(values form nil))))
((symbolp form)
;; will be cross-compiled correctly.
#-sb-xc-host (setf (symbol-value name) value)
#+sb-xc-host (progn
- (/show (symbol-package name))
;; Redefining our cross-compilation host's CL symbols
;; would be poor form.
;;
;;; 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.
+;;; relations are mimicked using structures for efficiency.
(sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-)
(:include pathname)
(:constructor %make-logical-pathname
,@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.")
+ "Apply PREDICATE to the 0-indexed elements of the sequences, then
+ possibly to those with index 1, and so on. Return the first
+ non-NIL value encountered, or NIL if the end of any 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
+ "Apply PREDICATE to the 0-indexed elements of the sequences, then
+ possibly to those with index 1, and so on. Return 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
+ "Apply PREDICATE to the 0-indexed elements of the sequences, then
+ possibly to those with index 1, and so on. Return NIL as soon
as any invocation of PREDICATE returns a non-NIL value, or T if the end
- of a sequence is reached.")
+ of any 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
+ "Apply PREDICATE to 0-indexed elements of the sequences, then
+ possibly to those with index 1, and so on. Return T as soon
as any invocation of PREDICATE returns NIL, or NIL if every invocation
is non-NIL."))
\f
;;; 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
+;;; arguments can't be evaluated (e.g. because they're only meaningful
+;;; in a debugging version of the system, or just due to bit rot..)
(defmacro /noshow (&rest rest)
(declare (ignore rest)))
#+sb-xc-host `(/show "(/primitive-print)" ,thing)
#-sb-xc-host `(sb!sys:%primitive print (the simple-string ,thing))))
-(defmacro /nohexstr (thing)
- (declare (ignore thing)))
-
;;; low-level display of a system word, works even early in cold init
(defmacro /hexstr (thing)
(declare (ignorable thing)) ; (for when #!-SB-SHOW)
(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)
--- /dev/null
+;;;; miscellaneous primitive stubs (ordinary FDEFINITIONs for full
+;;;; call defined in terms of fundamental definitions of inline
+;;;; 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")
+
+(macrolet ((def-frob (name &optional (args '(x)))
+ `(defun ,name ,args (,name ,@args))))
+ (def-frob %code-code-size)
+ (def-frob %code-debug-info)
+ (def-frob %code-entry-points)
+ (def-frob %funcallable-instance-function)
+ (def-frob %funcallable-instance-layout)
+ (def-frob %funcallable-instance-lexenv)
+ (def-frob %function-next)
+ (def-frob %function-self)
+ (def-frob %set-funcallable-instance-function (fin new-val)))
(t
(error "~S is not an alien function." alien)))))
-(defmacro def-alien-routine (name result-type &rest args &environment env)
+(defmacro def-alien-routine (name result-type &rest args &environment lexenv)
#!+sb-doc
- "Def-C-Routine Name Result-Type
- {(Arg-Name Arg-Type [Style])}*
+ "DEF-ALIEN-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.
+ Define a foreign interface function for the routine with the specified NAME.
+ Also automatically DECLAIM the FTYPE of the defined function.
- 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.
+ NAME may be either a string, a symbol, or a 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 specify 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
+ way that the argument is passed.
:IN
- An :In argument is simply passed by value. The value to be passed is
+ 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.
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.
+ This is similar to :IN, except that the argument values are stored
+ on the stack, and a pointer to the object is passed instead of
+ the value itself.
: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."
+ This is 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)
(unless (eq style :out)
(lisp-args name))
(when (and (member style '(:out :in-out))
- (typep (parse-alien-type type env)
+ (typep (parse-alien-type type lexenv)
'alien-pointer-type))
(error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S"
type))
(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 (make-gensym-list
- (length
- (alien-values-type-values result-type)))))
- `(multiple-value-bind ,temps
- (alien-funcall ,lisp-name ,@(alien-args))
- (values ,@temps ,@(results))))
- `(values (alien-funcall ,lisp-name ,@(alien-args))
- ,@(results))))))))
+ `(progn
+
+ ;; The theory behind this automatic DECLAIM is that (1) if
+ ;; you're calling C, static typing is what you're doing
+ ;; anyway, and (2) such a declamation can be (especially for
+ ;; alien values) both messy to do by hand and very important
+ ;; for performance of later code which uses the return value.
+ (declaim (ftype (function (mapcar (constantly t) ',args)
+ (alien ,result-type))
+ ,lisp-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 (make-gensym-list
+ (length
+ (alien-values-type-values result-type)))))
+ `(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
(%function-name x))
(#.sb!vm:funcallable-instance-header-type
(typecase x
+ ;; FIXME: byte compiler to go away completely
+ #|
(byte-function
(sb!c::byte-function-name x))
(byte-closure
(sb!c::byte-function-name (byte-closure-function x)))
+ |#
(t ;; funcallable-instance
(%function-name
(funcallable-instance-function x))))))))
(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))))
+(defun %package-hashtable-symbol-count (table)
+ (let ((size (the fixnum
+ (- (the fixnum (package-hashtable-size table))
+ (the fixnum
+ (package-hashtable-deleted table))))))
+ (declare (fixnum size))
+ (the fixnum
+ (- size
+ (the fixnum
+ (package-hashtable-free table))))))
+
+(defun package-internal-symbol-count (package)
+ (%package-hashtable-symbol-count (package-internal-symbols package)))
+
+(defun package-external-symbol-count (package)
+ (%package-hashtable-symbol-count (package-external-symbols package)))
\f
(defvar *package* (error "*PACKAGE* should be initialized in cold load!")
#!+sb-doc "the current package")
;;;; logical pathname support. ANSI 92-102 specification.
;;;;
;;;; As logical-pathname translations are loaded they are
-;;;; canonicalized as patterns to enable rapid efficent translation
+;;;; canonicalized as patterns to enable rapid efficient translation
;;;; into physical pathnames.
;;;; utilities
(defun (setf logical-pathname-translations) (translations host)
#!+sb-doc
- "Set the translations list for the logical host argument.
- Return translations."
+ "Set the translations list for the logical host argument."
(declare (type (or string logical-host) host)
(type list translations)
(values list))
(canonicalize-logical-pathname-translations translations host))
(setf (logical-host-translations host) translations)))
-(defun translate-logical-pathname (pathname &key)
- #!+sb-doc
- "Translate PATHNAME to a physical pathname, which is returned."
+;;; KLUDGE: Ordinarily known functions aren't defined recursively, and
+;;; it's common for compiler problems (e.g. missing/broken
+;;; optimization transforms) to cause them to recurse inadvertently,
+;;; so the compiler should warn about it. But the natural definition
+;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want
+;;; the warning, so we hide the definition of T-L-P in this
+;;; differently named function so that the compiler won't warn about
+;;; it. -- WHN 2001-09-16
+(defun %translate-logical-pathname (pathname)
(declare (type pathname-designator pathname)
(values (or null pathname)))
(typecase pathname
(stream (translate-logical-pathname (pathname pathname)))
(t (translate-logical-pathname (logical-pathname pathname)))))
+(defun translate-logical-pathname (pathname &key)
+ #!+sb-doc
+ "Translate PATHNAME to a physical pathname, which is returned."
+ (declare (type pathname-designator pathname)
+ (values (or null pathname)))
+ (%translate-logical-pathname pathname))
+
(defvar *logical-pathname-defaults*
(%make-logical-pathname (make-logical-host :name "BOGUS")
:unspecific
;;; Pull the type specifier out of a function object.
(defun extract-function-type (fun)
(typecase fun
+ ;; FIXME: byte compiler to be deleted completely
+ #|
(byte-function (byte-function-type fun))
(byte-closure (byte-function-type (byte-closure-function fun)))
+ |#
(t
(specifier-type (%function-type (%closure-function fun))))))
\f
#!+sb-doc
"the fixnum closest in value to negative infinity")
\f
-;;;; magic specials initialized by genesis
+;;;; magic specials initialized by GENESIS
;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
;;; of all static symbols in early-impl.lisp.
\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.
+;;; 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)
+ (/show0 "back from INFINITE-ERROR-PROTECTOR")
(let ((*current-error-depth* (1+ *current-error-depth*)))
+ (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
+ #+sb-show (sb-debug:backtrace)
,@forms)))
;;; a helper function for INFINITE-ERROR-PROTECT
(defun infinite-error-protector ()
+ (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..")
+ (/hexstr *current-error-depth*)
(cond ((not *cold-init-complete-p*)
(%primitive print "Argh! error in cold init, halting")
(%primitive sb!c:halt))
(%primitive print "Argh! corrupted error depth, halting")
(%primitive sb!c:halt))
((> *current-error-depth* *maximum-error-depth*)
+ (/show0 "*MAXIMUM-ERROR-DEPTH*=..")
+ (/hexstr *maximum-error-depth*)
(/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
(error-error "Help! "
*current-error-depth*
"KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
t)
(t
+ (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
nil)))
;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
(defconstant bytes-per-scrub-unit 2048)
-;;; Zero the unused portion of the control stack so that old objects are not
-;;; kept alive because of uninitialized stack variables.
+;;; 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
(defun context-pc (context)
(declare (type (alien (* os-context-t)) context))
- (int-sap (deref (context-pc-addr context))))
+ (let ((addr (context-pc-addr context)))
+ (declare (type (alien (* unsigned-int)) addr))
+ (int-sap (deref addr))))
(def-alien-routine ("os_context_register_addr" context-register-addr)
(* unsigned-int)
(context (* os-context-t))
(index int))
-;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
-;;; (Are they used in anything time-critical, or just the debugger?)
(defun context-register (context index)
(declare (type (alien (* os-context-t)) context))
- (deref (context-register-addr context index)))
+ (let ((addr (context-register-addr context index)))
+ (declare (type (alien (* unsigned-int)) addr))
+ (deref addr)))
(defun %set-context-register (context index new)
-(declare (type (alien (* os-context-t)) context))
-(setf (deref (context-register-addr context index))
- new))
+ (declare (type (alien (* os-context-t)) context))
+ (let ((addr (context-register-addr context index)))
+ (declare (type (alien (* unsigned-int)) addr))
+ (setf (deref addr) new)))
;;; This is like CONTEXT-REGISTER, but returns the value of a float
;;; register. FORMAT is the type of float to return.
(/hexstr context)
(let ((pc (context-pc context)))
(declare (type system-area-pointer pc))
+ (/show0 "got PC")
;; using INT3 the pc is .. INT3 <here> code length bytes...
(let* ((length (sap-ref-8 pc 1))
(vector (make-array length :element-type '(unsigned-byte 8))))
(defvar *fp-constant-1s0*)
(defvar *fp-constant-0d0*)
(defvar *fp-constant-1d0*)
-;;; The long-float constants.
+;;; the long-float constants
(defvar *fp-constant-0l0*)
(defvar *fp-constant-1l0*)
(defvar *fp-constant-pi*)
(defvar *fp-constant-lg2*)
(defvar *fp-constant-ln2*)
-;;; The current alien stack pointer; saved/restored for non-local exits.
+;;; 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)
;;; 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.
+;;; 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))
(in-package "SB-COLD")
\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.)
+;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-, but
+;;;; for *SHEBANG-FEATURES* instead of CL:*FEATURES*. (This is handy
+;;;; when cross-compiling, so that we can make 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*)
(defun shebang-reader (stream sub-character infix-parameter)
(declare (ignore sub-character))
(when infix-parameter
- (error "illegal read syntax: #~DT" infix-parameter))
+ (error "illegal read syntax: #~D!" infix-parameter))
(let ((next-char (read-char stream)))
(unless (find next-char "+-")
(error "illegal read syntax: #!~C" next-char))
(element-type '*)
unsafe?
fail-inline?)
- (/show "in %WITH-ARRAY-DATA-MACRO, yes.." array start end)
(let ((size (gensym "SIZE-"))
(defaulted-end (gensym "DEFAULTED-END-"))
(data (gensym "DATA-"))
;;; This structure holds the state of the assembler.
(defstruct (segment (:copier nil))
;; the name of this segment (for debugging output and stuff)
- (name "Unnamed" :type simple-base-string)
+ (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.
;; 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.
+ ;; *** 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
(:predicate alignment-p)
(:constructor make-alignment (bits size fill-byte))
(:copier nil))
- ;; The minimum number of low-order bits that must be zero.
+ ;; 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.
+ ;; 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.
+ ;; 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
(:include annotation)
(:constructor make-back-patch (size function))
(:copier nil))
- ;; The area effected by this back-patch.
+ ;; the area effected by this back-patch
(size 0 :type index)
- ;; The function to use to generate the real data
+ ;; 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
(error "You can only specify :VOP-VAR once per instruction.")
(setf vop-var (car args))))
(:printer
+ (sb!int:/noshow "uniquifying :PRINTER with" args)
(push (eval `(list (multiple-value-list
,(sb!disassem:gen-printer-def-forms-def-form
name
+ (format nil "~A[~A]" name args)
(cdr option-spec)))))
pdefs))
(:printer-list
(push
(eval
`(eval
- `(list ,@(mapcar #'(lambda (printer)
- `(multiple-value-list
- ,(sb!disassem:gen-printer-def-forms-def-form
- ',name printer nil)))
+ `(list ,@(mapcar (lambda (printer)
+ `(multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ ',name
+ (format nil "~A[~A]" ',name printer)
+ printer
+ nil)))
,(cadr option-spec)))))
pdefs))
(t
(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))
+ ;; (15 was %%DEFUN, no longer used as of sbcl-0.pre7.)
(def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
- ;; no longer used as of sbcl-0.pre7:
- #+nil (def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
+ ;; (17 was %%DEFCONSTANT, no longer used as of sbcl-0.pre7.)
(def-system-constant 18 '(%fdefinition-marker% . length))
(def-system-constant 19 '(%fdefinition-marker% . equal))
(def-system-constant 20 '(%fdefinition-marker% . append))
(let ((lambda (bind-lambda bind))
(env (node-environment bind)))
(ecase (lambda-kind lambda)
- ((nil :top-level :escape :cleanup :optional)
+ ((nil :external :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)))
(defun generate-xeps (component)
(let ((xeps nil))
(dolist (lambda (component-lambdas component))
- (when (member (lambda-kind lambda) '(:external :top-level))
+ (when (or (member (lambda-kind lambda) '(:external :top-level))
+ (lambda-has-external-references-p lambda))
(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
+ ;; 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.
+ ;; We don't generate any code for pure :EXTERNAL lambdas, so we
+ ;; don't need to allocate stack space for them. Also, we don't use
+ ;; the ``more'' entry point, so we don't need code for it.
(cond
- ((or (eq (lambda-kind lambda) :external)
+ ((or (and (eq (lambda-kind lambda) :external)
+ (not (lambda-has-external-references-p lambda)))
(and (eq (lambda-kind lambda) :optional)
(eq (optional-dispatch-more-entry
(lambda-optional-dispatch lambda))
(values))
(defun byte-compile-component (component)
+ (/show "entering BYTE-COMPILE-COMPONENT")
(setf (component-info component) (make-byte-component-info))
(maybe-mumble "ByteAnn ")
(make-core-byte-component segment code-length constants xeps
*compile-object*))
(null))))))
+ (/show "leaving BYTE-COMPILE-COMPONENT")
(values))
\f
;;;; extra stuff for debugging
;;; 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.
+;;; 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.)
(setf (basic-combination-kind dest) :error)))
(values))
-;;; Loop over all blocks in Component that have TYPE-CHECK set,
+;;; 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.
;;; 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
+;;; -- 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))
(setf (block-in block) nil)
(setf (block-gen block) gen)
- (setf (block-kill block) (kill))
+ (setf (block-kill-list block) (kill))
(setf (block-out block) (copy-sset gen))
(setf (block-type-asserted block) nil)
(values))))
(dolist (let (lambda-lets fun))
(frob let)))))
-;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
+;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
;;; Our OUT is:
;;; out U (in - kill)
;;;
-;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must
+;;; BLOCK-KILL-LIST 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
(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?")))
+ (let ((*compiler-error-context* (block-last block)))
+ (compiler-warning
+ "unreachable code in constraint ~
+ propagation -- apparent compiler bug"))
(make-sset))))
- (kill (block-kill block))
+ (kill-list (block-kill-list block))
(out (block-out block)))
(setf (block-in block) in)
- (cond ((null kill)
+ (cond ((null kill-list)
(sset-union (block-out block) in))
- ((null (rest kill))
- (let ((con (lambda-var-constraints (first kill))))
+ ((null (rest kill-list))
+ (let ((con (lambda-var-constraints (first kill-list))))
(if con
(sset-union-of-difference out in con)
(sset-union out in))))
(t
(let ((kill-set (make-sset)))
- (dolist (var kill)
+ (dolist (var kill-list)
(let ((con (lambda-var-constraints var)))
(when con
(sset-union kill-set con))))
(sset-union-of-difference (block-out block) in kill-set))))))
+;;; How many blocks does COMPONENT have?
+(defun component-n-blocks (component)
+ (let ((result 0))
+ (declare (type index result))
+ (do-blocks (block component :both)
+ (incf result))
+ result))
+
(defun constraint-propagate (component)
(declare (type component component))
(init-var-constraints component)
(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)))
+ (let (;; If we have to propagate changes more than this many times,
+ ;; something is wrong.
+ (max-n-changes-remaining (component-n-blocks component)))
+ (declare (type fixnum max-n-changes-remaining))
+ (loop (aver (plusp max-n-changes-remaining))
+ (decf max-n-changes-remaining)
+ (let ((did-something nil))
+ (do-blocks (block component)
+ (when (flow-propagate-constraints block)
+ (setq did-something t)))
+ (unless did-something
+ (return)))))
(do-blocks (block component)
(use-result-constraints block))
-;;;; This file contains the control analysis pass in the compiler. This
-;;;; pass determines the order in which the IR2 blocks are to be
+;;;; 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
(in-package "SB!C")
-;;; Insert Block in the emission order after the block After.
+;;; 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-prev next) block))
(values))
-;;; If Block looks like the head of a loop, then attempt to rotate it.
+;;; 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
(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.
+;;; 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.
+;;; 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.)
+;;; 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.
+;;; 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)
(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.
+;;; 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.
+;;; 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)))
(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.
+;;; 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.
+;;; 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)
(let ((2comp (component-info component)))
(when (ir2-component-p 2comp)
- ;; If it's not an ir2-component, don't worry about it.
+ ;; 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)))))
(or (= speed 3) (< debug 2)))))
arg-tn)))))))
-;;; Init the sets in Block for copy propagation. To find Gen, we just
+;;; 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
+;;; 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)
(sset-adjoin y kill))))))))))
(setf (block-out block) (copy-sset gen))
- (setf (block-kill block) kill)
+ (setf (block-kill-sset block) kill)
(setf (block-gen block) gen))
(values))
-;;; Do the flow analysis step for copy propagation on Block. We rely
+;;; 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.
(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))))
+ (sset-union-of-difference (block-out block)
+ in
+ (block-kill-sset block))))
(defevent copy-deleted-move "Copy propagation deleted a move.")
(coerce-to-smallest-eltype (res))))
-;;; Return a vector of SC offsets describing Fun's return locations.
+;;; 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
(eq fun (optional-dispatch-main-entry dispatch)))))
(make-compiled-debug-function
:name (cond ((leaf-name fun))
- ((let ((ef (functional-entry-function
- fun)))
+ ((let ((ef (functional-entry-function fun)))
(and ef (leaf-name ef))))
((and main-p (leaf-name dispatch)))
(t
(format t "~D: " number)
(print-vop vop)))
-;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block.
+;;; This is 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 block))
(values))
-;;; Do a Print-Nodes on Block and all blocks reachable from it by successor
-;;; links.
+;;; 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)
(walk block))
(values))
-;;; Print all blocks in Block's component in DFO.
+;;; 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)
(defvar *list-conflicts-table* (make-hash-table :test 'eq))
-;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when
+;;; 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))
(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
+;;; 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))
(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,
+;;; 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)
(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 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.
+;;; 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)))
(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.
+;;; This is 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 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.
+;;; 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)))
(add-to-dfo block (component-head current))
current)))))
-;;; Return a list of all the home lambdas that reference Fun (may contain
-;;; duplications).
+;;; 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 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. (And now that HAS-EXTERNAL-REFERENCES-P-ness
+;;; generalizes :TOP-LEVEL-ness, we ignore those too.) All other
+;;; references must cause components to be joined.
;;;
-;;; References in deleted functions are also ignored, since this code will be
-;;; deleted eventually.
+;;; 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)
+ (home-kind (functional-kind home))
+ (home-externally-visible-p
+ (or (eq home-kind :top-level)
+ (functional-has-external-references-p home))))
+ (unless (or (and home-externally-visible-p
(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.
+;;; 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.
+;;; 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.
+;;; 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 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.
+;;; 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)))
((null funs) res)
(declare (type component res))))))))
-;;; Return true if Fun is either an XEP or has EXITS to some of its ENTRIES.
+;;; 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)
(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.
+;;; 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)
(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)
+ (has-top (find :top-level funs :key #'functional-kind))
+ (has-external-references
+ (some #'functional-has-external-references-p funs)))
+ (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
+ ;; is newer than the rest of this function, and
+ ;; doesn't really seem to fit into its mindset. Here
+ ;; we mark components which contain such FUNCTIONs
+ ;; them as :COMPLEX-TOP-LEVEL, since they do get
+ ;; executed at run time, and since it's not valid to
+ ;; delete them just because they don't have any
+ ;; references from pure :TOP-LEVEL components. -- WHN
+ has-external-references
+ (setf (component-kind com) :complex-top-level)
+ (real com)
+ (real-top com))
+ ((or (some #'has-xep-or-nlx funs)
(and has-top (rest funs)))
(setf (component-name com) (find-component-name com))
(real com)
(values (real) (top) (real-top))))
-;;; Given a list of top-level lambdas, return three lists of components
-;;; representing the actual component division:
+;;; 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 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.
+;;; 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.
+;;; 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))
(defun merge-1-tl-lambda (result-lambda lambda)
(declare (type clambda result-lambda lambda))
- ;; Delete the lambda, and combine the lets and entries.
+ ;; 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)
(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.)
+ ;; Move blocks into the new COMPONENT, and move any nodes directly
+ ;; in the old LAMBDA into the new one (with LETs implicitly moved
+ ;; by changing their home.)
(do-blocks (block component)
(do-nodes (node cont block)
(let ((lexenv (node-lexenv node)))
(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.
+ ;; 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))
(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.
+ ;; 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))
(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.
+;;; 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))
(cond
(result-return
- ;; Make sure the result's return node starts a block so that we can
- ;; splice code in before it.
+ ;; 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)))))
documentation for SET-DISASSEM-PARAMS for more info."
(destructuring-bind
(&key instruction-alignment
- address-size
- (opcode-column-width nil opcode-column-width-p))
+ 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)))
+ ;; 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))))
+ (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
#!-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))
+ dchunk-make-mask dchunk-make-field
+ sap-ref-dchunk
+ dchunk-extract
+ dchunk=
+ dchunk-count-bits))
(defconstant dchunk-bits 32)
(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)))
+ (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)))))
+ (+ (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))
+ (+ (byte-position pos) (- dchunk-bits unit-bits)))
+ (the dchunk from))
(ldb pos (the dchunk from))))
(defmacro dchunk-insertf (place pos value)
(logcount x))
\f
(defstruct (instruction (:conc-name inst-)
- (:constructor
- make-instruction (name
- format-name
- print-name
- length
- mask id
- printer
- labeller prefilter control))
- (:copier nil))
+ (:constructor
+ make-instruction (name
+ format-name
+ print-name
+ length
+ mask id
+ printer
+ labeller prefilter control))
+ (:copier nil))
(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
+ (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
+ (length 0 :type length) ; in bytes
(print-name nil :type symbol)
(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
+;;;; an instruction space holds all known machine instructions in a
+;;;; form that can be easily searched
(defstruct (inst-space (:conc-name ispace-)
- (:copier nil))
- (valid-mask dchunk-zero :type dchunk) ; applies to *children*
+ (:copier nil))
+ (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-)
- (:copier nil))
- (common-id dchunk-zero :type dchunk) ; applies to *parent's* mask
+ (:copier nil))
+ (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
(defvar *disassem-arg-types* nil)
(defvar *disassem-function-cache* (make-function-cache))
-(defstruct (argument (:conc-name arg-))
+(defstruct (argument (:conc-name arg-)
+ (:copier nil))
(name nil :type symbol)
(fields nil :type list)
(use-label nil))
(defstruct (instruction-format (:conc-name format-)
- (:copier nil))
+ (:copier nil))
(name nil)
(args nil :type list)
- (length 0 :type length) ; in bytes
+ (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)
- (:copier nil))
+ (:constructor %make-funstate)
+ (:copier nil))
(args nil :type list)
- (arg-temps nil :type list)) ; See below.
+ (arg-temps nil :type list)) ; See below.
(defun make-funstate (args)
;; give the args a position
(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)))
+ (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)))
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.
+;;;; (notably functions), we sometimes use a VALSRC structure to keep
+;;;; track of the source from which they were derived.
(defstruct (valsrc (:constructor %make-valsrc)
- (:copier nil))
+ (:copier nil))
(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))))
+ 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)
+ (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.
+;;; 1. This should become a utility in SB!INT.
+;;; 2. Arrays and structures and maybe other things are
+;;; self-evaluating too.
(defun self-evaluating-p (x)
(typecase x
(null 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
+;;; 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)))))
+ (eq (car form) 'function)
+ (symbolp (cadr form)))))
(defun make-wrapper (form arg-name funargs prefix)
(if (and (listp form)
- (eq (car form) 'function))
+ (eq (car form) 'function))
;; a function def
(let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER"))
- (wrapper-args (make-gensym-list (length funargs))))
- (values `#',wrapper-name
- `(defun ,wrapper-name ,wrapper-args
- (funcall ,form ,@wrapper-args))))
+ (wrapper-args (make-gensym-list (length funargs))))
+ (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)))))
+ (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))
+ (list* (car override) (cadr override)
+ (munge-fun-refs (cddr override) evalp)))
+ overrides))
(defparameter *arg-function-params*
'((:printer . (value stream 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)))
+ (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))))))))
+ (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)
+ (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))
+(defun gen-printer-def-forms-def-form (base-name
+ uniquified-name
+ def
+ &optional
+ (evalp t))
+ (declare (type symbol base-name))
+ (declare (type (or symbol string) uniquified-name))
(destructuring-bind
(format-name
(&rest field-defs)
&optional (printer-form :default)
- &key ((:print-name print-name-form) `',name) control)
+ &key ((:print-name print-name-form) `',base-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))))
- ))))))))
+ (field-defs (filter-overrides field-defs evalp)))
+ `(let* ((*current-instruction-flavor* ',(cons base-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 ',uniquified-name
+ ',format-name
+ ,(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 ',uniquified-name args funcache)
+ (multiple-value-bind (prefilter-fun prefilter-defun)
+ (find-prefilter-fun ',uniquified-name
+ ',format-name
+ args
+ funcache)
+ (multiple-value-bind (mask id)
+ (compute-mask-id args)
+ (values
+ `(make-instruction ',',base-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)
+ &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))))
+ ,(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*)
(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))
+ (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))))))))))
+ (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)
+ 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))))))
+ (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-structure (nth arg-pos args))))))
(when (and field-p (not fields-p))
(setf fields (list field))
(setf fields-p t))
(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))
+ (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)))
+ (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)))
+ (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)
+ (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))))))
+ (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))))
+ &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))
+ (listp forms)
+ (/= (length forms) 1))
(pd-error "~S must not have multiple values." arg))
(maybe-listify forms)))
(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))))))
+ (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)
(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 (make-gensym-list (length forms)))))
- (set-arg-temps vars forms arg kind funstate)))
+ (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 (make-gensym-list (length forms)))))
+ (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))))
+ 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)))
(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))))
+ (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)))
+ (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))))))
+ (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)
`(progn
,@wrapper-defs
(eval-when (:compile-toplevel :execute)
- ,(update-args-form '*disassem-arg-types* `',name args evalp))
+ ,(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)))
+ `(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)))
+ (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))))
+ (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)))
+ (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))))
+ (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))))
+ (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))))
+ (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))))
+ (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))))
+ (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))))))
+ (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)))
+ (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))))
+ (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)))
+ (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))))
+ (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!"))
+ (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))))
+ (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
(defun remember-printer-use (arg funstate)
(set-arg-temps nil nil arg :printed funstate))
;;; 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.
+ (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)))
+
+;;; Return 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-)
- (:copier nil))
+ (:copier nil))
(funstate nil :type (or null funstate))
(constraint nil :type list)
(name nil :type (or null symbol)))
(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)
+ (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
+ (stem (required-argument)))
+ &body defun-maker-forms)
(let ((cache-var (gensym))
- (constraint-var (gensym)))
+ (constraint-var (gensym)))
`(let* ((,constraint-var ,constraint)
- (,cache-var (find-cached-function (,cache-slot ,cache)
- ,args ,constraint-var)))
+ (,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)))))))))))
+ (values (cached-fun-name ,cache-var) nil))
+ (t
+ (let* ((,name-var (symbolicate "CACHED-FUN--" ,stem))
+ (,funstate-var (make-funstate ,args))
+ (,cache-var
+ (make-cached-function :name ,name-var
+ :funstate ,funstate-var
+ :constraint ,constraint-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)
+(defun find-printer-fun (%name %format-name printer-source args cache)
+ (declare (type (or string symbol) %name))
(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)))))
+ (!with-cached-function
+ (name funstate cache function-cache-printers args
+ :constraint printer-source
+ :stem (concatenate 'string
+ (string %name)
+ "-"
+ (symbol-name %format-name)
+ "-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)))
+ (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)))
+ (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))))))
+ `(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))
+ (values (car form) (cdr form))
+ (values subj form))
(let ((key (if (consp test) (car test) test))
- (body (if (consp test) (cdr test) nil)))
+ (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)))))
+ (: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)))))
+ (: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
#!+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))))))
+ 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))))
+ 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
eq to the original."
(and list
(sharing-cons list
- (funcall fun (car list))
- (sharing-mapcar fun (cdr 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)))
+ 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))
+ (pd-error "no suitable choice found in ~S" choices))
(when (all-arg-refs-relevant-p choice args)
(return choice))))
;; 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))))
+ (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))))
+ (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)))))
+ 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)))
+ (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)))))
+ `(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))))))
+ (eq (car thing) 'quote)
+ (or (stringp (cadr thing))
+ (symbolp (cadr thing))))))
(defun strip-quote (thing)
(if (and (consp thing) (eq (car thing) 'quote))
\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 ((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))))))
+ `(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)))
+ test (cdr test)))
(let ((key (if (consp test) (car test) test))
- (body (if (consp test) (cdr test) nil)))
+ (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)))))
+ 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)
+(defun find-labeller-fun (%name args cache)
(let ((labelled-fields
- (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
+ (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))))
+ (values nil nil)
+ (!with-cached-function
+ (name funstate cache function-cache-labellers args
+ :stem (concatenate 'string "LABELLER-" (string %name))
+ :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 (%name %format-name args cache)
+ (declare (type (or symbol string) %name %format-name))
+ (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)))))))))
+ (values nil nil)
+ (!with-cached-function
+ (name funstate cache function-cache-prefilters args
+ :stem (concatenate 'string
+ (string %name)
+ "-"
+ (string %format-name)
+ "-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))
+ (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))))))))
+ (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))
+ flavors))
\f
#!-sb-fluid (declaim (inline bytes-to-bits))
(declaim (maybe-inline sign-extend aligned-p align tab tab0))
(defun sign-extend (int size)
(declare (type integer int)
- (type (integer 0 128) size))
+ (type (integer 0 128) size))
(if (logbitp (1- size) int)
(dpb int (byte size 0) -1)
int))
#!+sb-doc
"Returns non-NIL if ADDRESS is aligned on a SIZE byte boundary."
(declare (type address address)
- (type alignment size))
+ (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))
+ (type alignment size))
(logandc1 (1- size) (+ (1- size) address)))
(defun tab (column stream)
\f
(defun read-signed-suffix (length dstate)
(declare (type (member 8 16 32) length)
- (type disassem-state dstate)
- (optimize (speed 3) (safety 0)))
+ (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
(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))
+ #!+long-float
((complex long-float)
+ ;; (There's no easy way to mix #!+LONG-FLOAT and #-SB-XC-HOST
+ ;; conditionalization at read time, so we do this SB-XC-HOST
+ ;; conditional at runtime instead.)
+ #+sb-xc-host (error "can't dump COMPLEX-LONG-FLOAT in cross-compiler")
(dump-fop 'fop-complex-long-float file)
(dump-long-float (realpart x) file)
(dump-long-float (imagpart x) 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 sb!c::entry-info entry) (type index code-handle)
(type fasl-output file))
(dump-object (sb!c::entry-info-type entry) file)
(dump-fop 'fop-function-entry file)
(dump-unsigned-32 (label-position (sb!c::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 'fop-fset file))
- handle)))
+ (dump-pop file)))
;;; Alter the code object referenced by CODE-HANDLE at the specified
;;; OFFSET, storing the object referenced by ENTRY-HANDLE.
(dump-object nil file)
;; Dump the constants.
+ ;;
+ ;; FIXME: There's a family resemblance between this and the
+ ;; corresponding code in DUMP-CODE-OBJECT. Could some be shared?
(dotimes (i (length constants))
(let ((entry (aref constants i)))
(etypecase entry
(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 sb!c::clambda fun) (type fasl-output file))
+(defun dump-push-previously-dumped-fun (fun fasl-output)
+ (declare (type sb!c::clambda fun))
(let ((handle (gethash (sb!c::leaf-info fun)
- (fasl-output-entry-table file))))
+ (fasl-output-entry-table fasl-output))))
(aver handle)
- (dump-push handle file)
- (dump-fop 'fop-funcall-for-effect file)
- (dump-byte 0 file))
+ (dump-push handle fasl-output))
(values))
+;;; Dump a FOP-FUNCALL to call an already-dumped top-level lambda at
+;;; load time.
+(defun fasl-dump-top-level-lambda-call (fun fasl-output)
+ (declare (type sb!c::clambda fun))
+ (dump-push-previously-dumped-fun fun fasl-output)
+ (dump-fop 'fop-funcall-for-effect fasl-output)
+ (dump-byte 0 fasl-output)
+ (values))
+
+;;; Dump a FOP-FSET to arrange static linkage (at cold init) between
+;;; FUN-NAME and the already-dumped function whose dump handle is
+;;; FUN-DUMP-HANDLE.
+#+sb-xc-host
+(defun fasl-dump-cold-fset (fun-name fun-dump-handle fasl-output)
+ (declare (type fixnum fun-dump-handle))
+ (aver (legal-function-name-p fun-name))
+ (dump-non-immediate-object fun-name fasl-output)
+ (dump-push fun-dump-handle fasl-output)
+ (dump-fop 'fop-fset fasl-output)
+ (values))
+
;;; Compute the correct list of DEBUG-SOURCE structures and backpatch
;;; all of the dumped DEBUG-INFO structures. We clear the
;;; FASL-OUTPUT-DEBUG-INFO, so that subsequent components with
;;; different source info may be dumped.
-(defun fasl-dump-source-info (info file)
- (declare (type sb!c::source-info info) (type fasl-output file))
+(defun fasl-dump-source-info (info fasl-output)
+ (declare (type sb!c::source-info info))
(let ((res (sb!c::debug-source-for-info info))
(*dump-only-valid-structures* nil))
- (dump-object res file)
- (let ((res-handle (dump-pop file)))
- (dolist (info-handle (fasl-output-debug-info file))
- (dump-push res-handle file)
- (dump-fop 'fop-structset file)
- (dump-unsigned-32 info-handle file)
- (dump-unsigned-32 2 file))))
- (setf (fasl-output-debug-info file) nil)
+ (dump-object res fasl-output)
+ (let ((res-handle (dump-pop fasl-output)))
+ (dolist (info-handle (fasl-output-debug-info fasl-output))
+ (dump-push res-handle fasl-output)
+ (dump-fop 'fop-structset fasl-output)
+ (dump-unsigned-32 info-handle fasl-output)
+ (dump-unsigned-32 2 fasl-output))))
+ (setf (fasl-output-debug-info fasl-output) nil)
(values))
\f
;;;; dumping structures
(in-package "SB!C")
;;; 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
+;;; 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)
(*print-case* :downcase))
(write-to-string args)))))
-;;; Initialize Info structure to correspond to the XEP lambda Fun.
+;;; 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))
(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,
+;;; Replace all references to COMPONENT's non-closure XEPs that appear
+;;; in top-level or externally-referenced components, changing to
+;;; :TOP-LEVEL-XEP FUNCTIONALs. If the cross-component ref is not in a
+;;; :TOP-LEVEL/externally-referenced 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
+;;; 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/externally-referenced 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.
+;;; 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))))))))
+ (unless (lambda-has-external-references-p lambda)
+ (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 (component-top-levelish-p ref-component))
+ closure)
+ (setq res t))
+ (t
+ (setf (ref-leaf ref) new)
+ (push ref (leaf-refs new)))))))))
(:top-level
(setq res t))))
res))
;;;; 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
+;;;; structures, determining the environment that each LAMBDA
;;;; allocates its variables and finding what values are closed over
;;;; by each environment.
(in-package "SB!C")
-;;; Do environment analysis on the code in Component. This involves
+;;; 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.
+;;; 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
+;;; *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)
(when (null (leaf-refs fun))
(let ((kind (functional-kind fun)))
(unless (or (eq kind :top-level)
+ (functional-has-external-references-p fun)
(and *byte-compiling* (eq kind :optional)))
(aver (member kind '(:optional :cleanup :escape)))
(setf (functional-kind fun) nil)
(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.
+;;; This is to be called on a 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))
(setq found-it t))))
found-it))
-;;; If Fun has an environment, return it, otherwise assign one.
+;;; This is like old CMU CL PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL, except
+;;; (1) It's been brought into the post-0.7.0 world where the property
+;;; HAS-EXTERNAL-REFERENCES-P is orthogonal to the property of
+;;; being specialized/optimized for locall at top level.
+;;; (2) There's no return value, since we don't care whether we
+;;; find any possible closure variables.
+;;;
+;;; I wish I could find an explanation of why
+;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL is important. The old CMU CL
+;;; comments said
+;;; 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.
+;;; But that doesn't seem to explain why it's important. I do observe
+;;; that when it's not done, compiler assertions occasionally fail. My
+;;; tentative hypothesis is that other environment analysis expects to
+;;; bottom out on the outermost enclosing thing, and (insert
+;;; mysterious reason here) it's important to set up bottomed-out-here
+;;; environments before anything else. -- WHN 2001-09-30
+(defun preallocate-environments-for-top-levelish-lambdas (component)
+ (dolist (clambda (component-lambdas component))
+ (when (lambda-top-levelish-p clambda)
+ (compute-closure clambda)))
+ (values))
+
+;;; If FUN has an environment, return it, otherwise assign an empty one.
(defun get-lambda-environment (fun)
(declare (type clambda fun))
(let* ((fun (lambda-home fun))
(or env
(let ((res (make-environment :function fun)))
(setf (lambda-environment fun) res)
- (dolist (lambda (lambda-lets fun))
- (setf (lambda-environment lambda) res))
+ (dolist (letlambda (lambda-lets fun))
+ ;; This assertion is to make explicit an
+ ;; apparently-otherwise-undocumented property of existing
+ ;; code: We never overwrite an old LAMBDA-ENVIRONMENT.
+ ;; -- WHN 2001-09-30
+ (aver (null (lambda-environment letlambda)))
+ ;; I *think* this is true regardless of LAMBDA-KIND.
+ ;; -- WHN 2001-09-30
+ (aver (eql (lambda-home letlambda) fun))
+ (setf (lambda-environment letlambda) 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.
+;;; If FUN has no physical environment, assign one, otherwise clean up
+;;; the old physical environment, removing/flagging 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
(get-lambda-environment fun))))
(values))
-;;; Get node's environment, assigning one if necessary.
+;;; 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.
+;;; 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))
(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.
+;;; 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))
\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.
+;;; 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.
+;;; 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.
+;;; 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))
(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.
+;;; 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.
+;;; -- 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))
(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.
+;;; 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))
\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.
+;;; 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.
+;;; 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.
+;;; 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)
(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.
+;;; 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)
(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.
+;;; 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))
;;; 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.
+;;; we don't, he won't even get so much as an efficiency note.
(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
`(,(continuation-function-name (basic-combination-fun node))
(float x y) y))
(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)
+ ;; 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)
;; (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-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)
(cold-push (string-to-core (package-name pkg)) res)
res))
\f
-;;;; fdefinition objects
+;;;; functions and 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.
+;;; 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)))))
+;;; Given a cold representation of a symbol, return a warm
+;;; representation.
+(defun warm-symbol (des)
+ ;; Note that COLD-INTERN is responsible for keeping the
+ ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
+ ;; uninterned symbol, the code below will fail. But as long as we
+ ;; don't need to look up uninterned symbols during bootstrapping,
+ ;; that's OK..
+ (multiple-value-bind (symbol found-p)
+ (gethash (descriptor-bits des) *cold-symbols*)
+ (declare (type symbol symbol))
+ (unless found-p
+ (error "no warm symbol"))
+ symbol))
+
+;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
+(defun cold-car (des)
+ (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+ (read-wordindexed des sb!vm:cons-car-slot))
+(defun cold-cdr (des)
+ (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+ (read-wordindexed des sb!vm:cons-cdr-slot))
+(defun cold-null (des)
+ (= (descriptor-bits des)
+ (descriptor-bits *nil-descriptor*)))
+
+;;; Given a cold representation of a function name, return a warm
+;;; representation.
+(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
+(defun warm-fun-name (des)
+ (let ((result
+ (ecase (descriptor-lowtag des)
+ (#.sb!vm:list-pointer-type
+ (aver (not (cold-null des))) ; function named NIL? please no..
+ ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
+ (let* ((car-des (cold-car des))
+ (cdr-des (cold-cdr des))
+ (cadr-des (cold-car cdr-des))
+ (cddr-des (cold-cdr cdr-des)))
+ (aver (cold-null cddr-des))
+ (list (warm-symbol car-des)
+ (warm-symbol cadr-des))))
+ (#.sb!vm:other-pointer-type
+ (warm-symbol des)))))
+ (unless (legal-function-name-p result)
+ (error "not a legal function name: ~S" result))
+ result))
(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
(declare (type descriptor cold-name))
- (let ((warm-name (warm-fdefn-name cold-name)))
+ (let ((warm-name (warm-fun-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)
(write-wordindexed fdefn
sb!vm:fdefn-raw-addr-slot
(make-random-descriptor
- (cold-foreign-symbol-address-as-integer "undefined_tramp"))))
+ (cold-foreign-symbol-address-as-integer
+ "undefined_tramp"))))
fdefn))))
-(defun cold-fset (cold-name defn)
+;;; Handle the at-cold-init-time, fset-for-static-linkage operation
+;;; requested by FOP-FSET.
+(defun static-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)))
\f
;;;; cold fops for loading symbols
-;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and intern
-;;; that symbol in PACKAGE.
+;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and
+;;; intern that symbol in PACKAGE.
(defun cold-load-symbol (size package)
(let ((string (make-string size)))
(read-string-as-bytes *fasl-input-stream* string)
(let* ((size (clone-arg))
(name (make-string size)))
(read-string-as-bytes *fasl-input-stream* name)
- (let ((symbol (allocate-symbol name)))
- (push-fop-table symbol))))
+ (let ((symbol-des (allocate-symbol name)))
+ (push-fop-table symbol-des))))
\f
;;;; cold fops for loading lists
\f
;;;; cold fops for loading code objects and functions
+;;; the names of things which have had COLD-FSET used on them already
+;;; (used to make sure that we don't try to statically link a name to
+;;; more than one definition)
+(defparameter *cold-fset-warm-names*
+ ;; This can't be an EQL hash table because names can be conses, e.g.
+ ;; (SETF CAR).
+ (make-hash-table :test 'equal))
+
(define-cold-fop (fop-fset nil)
- (let ((fn (pop-stack))
- (name (pop-stack)))
- (cold-fset name fn)))
+ (let* ((fn (pop-stack))
+ (cold-name (pop-stack))
+ (warm-name (warm-fun-name cold-name)))
+ (if (gethash warm-name *cold-fset-warm-names*)
+ (error "duplicate COLD-FSET for ~S" warm-name)
+ (setf (gethash warm-name *cold-fset-warm-names*) t))
+ (static-fset cold-name fn)))
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
(define-cold-fop (fop-sanctify-for-execution)
(pop-stack))
+;;; FIXME: byte compiler to be removed completely
+#|
(not-cold-fop fop-make-byte-compiled-function)
+|#
;;; Setting this variable shows what code looks like before any
;;; fixups (or function headers) are applied.
(if (= (descriptor-bits fun)
(descriptor-bits *nil-descriptor*))
(push name undefs)
- (let ((addr (read-wordindexed fdefn
- sb!vm:fdefn-raw-addr-slot)))
+ (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))
+ (setf funs (sort funs #'< :key #'cdr))
+ (dolist (info funs)
(format t "0x~8,'0X: ~S #X~8,'0X~%" (cdr info) (car info)
(- (cdr info) #x17)))
(format t
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)))
+
+ (setf undefs (sort undefs #'string< :key #'function-name-block-name))
+ (dolist (name undefs)
+ (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
(fdefinition-object (cdr const) t))))))))))
(values))
+;;; FIXME: byte compiler to go away completely
+#|
(defun make-core-byte-component (segment length constants xeps object)
(declare (type sb!assem:segment segment)
(type index length)
(setf (code-header-ref code-obj code-obj-index) xep))))))))))
(values))
-
+|#
\ No newline at end of file
(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.
+;;; 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))
(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)))))
+;;; Give CLAMBDA an IR2-ENVIRONMENT structure. (And in order to
+;;; properly initialize the new structure, we make the TNs which hold
+;;; environment values and the old-FP/return-PC.)
+(defun assign-ir2-environment (clambda)
+ (declare (type clambda clambda))
+ (let ((lambda-environment (lambda-environment clambda))
+ (reversed-ir2-environment-alist nil))
+ ;; FIXME: should be MAPCAR, not DOLIST
+ (dolist (thing (environment-closure lambda-environment))
+ (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*))))
+ (push (cons thing (make-normal-tn ptype))
+ reversed-ir2-environment-alist)))
- (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)))))
+ (let ((res (make-ir2-environment
+ :environment (nreverse reversed-ir2-environment-alist)
+ :return-pc-pass (make-return-pc-passing-location
+ (external-entry-point-p clambda)))))
+ (setf (environment-info lambda-environment) res)
+ (setf (ir2-environment-old-fp res)
+ (make-old-fp-save-location lambda-environment))
+ (setf (ir2-environment-return-pc res)
+ (make-return-pc-save-location lambda-environment))))
(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.
+;;; Return true if FUN's result continuation is used in a
+;;; tail-recursive 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)))
(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.
+;;; 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)))
(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)
+;;; If policy indicates, give an efficiency 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-efficiency-note (tails)
(declare (type tail-set tails))
(let ((funs (tail-set-functions tails)))
(when (policy (lambda-bind (first funs))
(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.
+;;; 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))
+ (return-value-efficiency-note tails))
(if (or (eq count :unknown) use-standard)
(make-return-info :kind :unknown
: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.
+;;; 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))
(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.
+;;; 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)))
))))))
;;; For each named function with an XEP, note the definition of that
-;;; name, and add derived type information to the info environment. We
+;;; 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)
(name (leaf-name leaf))
(defined-ftype (definition-type leaf)))
(setf (leaf-type leaf) defined-ftype)
- (when (or (and name (symbolp name))
- (and (consp name) (eq (car name) 'setf)))
+ (when (legal-function-name-p name)
(let* ((where (info :function :where-from name))
(*compiler-error-context* (lambda-bind (main-entry leaf)))
(global-def (gethash name *free-functions*))
(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.
+;;; This is 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)))
(reoptimize-continuation cont)))))
(values))
-;;; Assert that Call is to a function of the specified Type. It is
+;;; 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)
\f
;;;; IR1-OPTIMIZE
-;;; Do one forward pass over Component, deleting unreachable blocks
+;;; 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
+;;; 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
;;; 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.
+;;; 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.
;;;
;;; 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.
+;;; -- 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
;;; This is 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
+;;; 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.
+;;; -- 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.
+;;; FUNCTION-INFO assigned.
(defun recognize-known-call (call ir1-p)
(declare (type combination call))
(let* ((ref (continuation-use (basic-combination-fun call)))
\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,
+;;; 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)
\f
;;;; local call optimization
-;;; Propagate Type to Leaf and its Refs, marking things changed. If
+;;; 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.)
;;; 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
+;;; 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)
;;; 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
+;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on
;;; the original source.
(declaim (hash-table *source-paths*))
(defvar *source-paths*)
;;; *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)
+(defvar *current-path*)
(defvar *derive-function-types* nil
"Should the compiler assume that function types will never change,
;;; 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.
+;;; form in the current global environment. The returned lambda is a
+;;; 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
;;; *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.
+;;; to an initial value of 0 before the processing of each truly
+;;; top-level form.
(declaim (type index *current-form-number*))
(defvar *current-form-number*)
(pushnew fun (component-reanalyze-functions *current-component*)))
fun)
-;;; Generate a Ref node for LEAF, frobbing the LEAF structure as
+;;; 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.
(new-venv nil cons))
(dolist (var vars)
+ ;; As far as I can see, LAMBDA-VAR-HOME should never have
+ ;; been set before. Let's make sure. -- WHN 2001-09-29
+ (aver (null (lambda-var-home var)))
(setf (lambda-var-home var) lambda)
(let ((specvar (lambda-var-specvar var)))
(cond (specvar
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.
+;;; 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.
+;;; 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.
+;;; 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
+;;; 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.
+;;; 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
;;; 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
+;;; 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.
+;;; SUPPLIED-P args are present they may be different.
;;;
;;; When we run into a &REST or &KEY arg, we punt out to
;;; IR1-CONVERT-MORE, which finishes for us in this case.
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
+;;; 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.
+;;; 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
;;;; 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,
+;;; 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)
(ir1-convert-progn-body dummy cont forms))))
-;;; We make Cont start a block just so that it will have a block
+;;; 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.
+;;; 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
;;; 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
+ (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 the quote is 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.
+ ;; 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
(aver (eq 'function (first qdef)))
(aver (proper-list-of-length-p qdef 2))
;;; 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.
+;;; LAMBDA-WITH-LEXENV, 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)
+ (if (eq (car fun) 'lambda-with-lexenv)
(cdr fun)
`(() () () . ,(cdr fun)))
(let ((*lexenv* (make-lexenv
:policy (lexenv-policy *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
- (aver (eq (car what) 'macro))
- (push x symmacs))
- (global-var
- (aver (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.
;;; types if appropriate. 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.
+;;; 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))
(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.
+;;; the even-at-compile-time part of DEFUN
;;;
-;;; 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))))))
+;;; The INLINE-EXPANSION is a LAMBDA-WITH-LEXENV, or NIL if there is
+;;; no inline expansion.
+(defun %compiler-defun (name lambda-with-lexenv)
+
+ (let ((defined-function nil)) ; will be set below if we're in the compiler
+
+ ;; when in the compiler
+ (when (boundp '*lexenv*)
+ (when sb!xc:*compile-print*
+ (compiler-mumble "~&; recognizing DEFUN ~S~%" name))
+ (remhash name *free-functions*)
+ (setf defined-function (get-defined-function name)))
+
+ (become-defined-function-name name)
+
+ (cond (lambda-with-lexenv
+ (setf (info :function :inline-expansion name) lambda-with-lexenv)
+ (when defined-function
+ (setf (defined-function-inline-expansion defined-function)
+ lambda-with-lexenv)))
+ (t
+ (clear-info :function :inline-expansion name)))
+
+ ;; old CMU CL comment:
+ ;; If there is a type from a previous definition, blast it,
+ ;; since it is obsolete.
+ (when (and defined-function
+ (eq (leaf-where-from defined-function) :defined))
+ (setf (leaf-type defined-function)
+ ;; FIXME: If this is a block compilation thing, shouldn't
+ ;; we be setting the type to the full derived type for the
+ ;; definition, instead of this most general function type?
+ (specifier-type 'function))))
+
+ (values))
+\f
+;;;; hacking function names
+
+;;; This is like LAMBDA, except the result is tweaked so that
+;;; %FUNCTION-NAME or BYTE-FUNCTION-NAME can extract a name. (Also
+;;; possibly the name could also be used at compile time to emit
+;;; more-informative name-based compiler diagnostic messages as well.)
+(defmacro-mundanely named-lambda (name args &body body)
+
+ ;; FIXME: For now, in this stub version, we just discard the name. A
+ ;; non-stub version might use either macro-level LOAD-TIME-VALUE
+ ;; hackery or customized IR1-transform level magic to actually put
+ ;; the name in place.
+ (aver (legal-function-name-p name))
+ `(lambda ,args ,@body))
\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.
+;;; 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)
(the environment (lambda-environment (node-home-lambda node))))
;;; Return the enclosing cleanup for environment of the first or last node
-;;; in Block.
+;;; in BLOCK.
(defun block-start-cleanup (block)
(declare (type cblock block))
(node-enclosing-cleanup (continuation-next (block-start block))))
(declare (type cblock block))
(node-enclosing-cleanup (block-last block)))
-;;; Return the non-let lambda that holds Block's code.
+;;; 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.
+;;; 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
+;;; Return the Top Level Form number of PATH, i.e. the ordinal number
;;; of its original 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 original source
+;;; Return the (reversed) list for the PATH in the original source
;;; (with the Top Level Form 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 original source inside the Top
+;;; Return the Form Number of PATH's original 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)
(defun source-path-forms (path)
(subseq path 0 (position 'original-source-start path)))
-;;; Return the innermost source form for Node.
+;;; Return the innermost source form for NODE.
(defun node-source-form (node)
(declare (type node node))
(let* ((path (node-source-path node))
(aver (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.
+;;; This is 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)))
(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.
+;;; 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)
(values))
;;; Unlink a block from the next/prev chain. We also null out the
-;;; Component.
+;;; 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-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))
+;;; Add BLOCK to the next/prev chain following AFTER. We also set the
+;;; Component to be the same as for AFTER.
(defun add-to-dfo (block after)
(declare (type cblock block after))
(let ((next (block-next after))
(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.
+;;; 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))
(setf (block-flag block) nil)))
(values))
-;;; Make a component with no blocks in it. The Block-Flag is initially
+;;; 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 ()
(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.
+;;; Make 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))
\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.
+;;; 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.
+;;; 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))
(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.
+;;; 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)))
(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 a function that has 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)
(aver (and (null (leaf-refs 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.
+;;; 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 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
+;;; 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)))
(aver (not (member kind '(:deleted :optional :top-level))))
+ (aver (not (functional-has-external-references-p leaf)))
(setf (functional-kind leaf) :deleted)
(setf (lambda-bind leaf) nil)
(dolist (let (lambda-lets leaf))
(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.
+;;; 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.)
+;;; 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.
+;;; 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)))
(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.
+;;; 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))
(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.
+;;; 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.
+;;; 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))
(values))
-;;; Do a graph walk backward from Block, marking all predecessor blocks with
-;;; the DELETE-P flag.
+;;; 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)
(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.
+;;; 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.
+;;; 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))
(aver (not (eq (continuation-kind cont) :deleted)))
(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.
+ ;; 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.
(remove-from-dfo block)
(values))
-;;; Do stuff to indicate that the return node Node is being deleted. We set
-;;; the RETURN to NIL.
+;;; 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)))
(setf (lambda-return fun) nil))
(values))
-;;; If any of the Vars in fun were never referenced and was not declared
-;;; IGNORE, then complain.
+;;; If any of the VARS in FUN was never referenced and was not
+;;; declared IGNORE, then complain.
(defun note-unreferenced-vars (fun)
(declare (type clambda fun))
(dolist (var (lambda-vars fun))
(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 #'.
+;;; 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)
(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.
+;;; 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 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 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.
+;;; -- 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)
(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.)
+;;; 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.
+;;; 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))
(setf (node-prev node) nil)
t)))))))
-;;; Return true if NODE has been deleted, false if it is still a valid part
-;;; of IR1.
+;;; 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)))
(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.
+;;; 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))
(aver (null (component-new-functions component)))
(reoptimize-continuation (node-cont ref)))
(values))
-;;; Change all Refs for Old-Leaf to New-Leaf.
+;;; 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
+;;; Like SUBSITUTE-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))
(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.
+;;; 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))
: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.
+;;; 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)))
\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
(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.
+;;; RETURN 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)
(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))
+;;; (:EXTERNAL kind) and top-level lambdas (:TOP-LEVEL kind.)
(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.
+;;; 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)))
nil))
nil)))
-;;; Return the COMBINATION node that is the call to the let Fun.
+;;; Return the COMBINATION node that is the call to the LET FUN.
(defun let-combination (fun)
(declare (type clambda fun))
(aver (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.
+;;; Return the initial value continuation for a LET variable, or NIL
+;;; if there is none.
(defun let-var-initial-value (var)
(declare (type lambda-var var))
(let ((fun (lambda-var-home var)))
(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.)")
+ "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
+;;; 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
(node-block node))))))
(cond ((> expanded *inline-expansion-limit*) nil)
((= expanded *inline-expansion-limit*)
+ ;; FIXME: If the objective is to stop the recursive
+ ;; expansion of inline functions, wouldn't it be more
+ ;; correct to look back through surrounding expansions
+ ;; (which are, I think, stored in the *CURRENT-PATH*, and
+ ;; possibly stored elsewhere too) and suppress expansion
+ ;; and print this warning when the function being proposed
+ ;; for inline expansion is found there? (I don't like the
+ ;; arbitrary numerical limit in principle, and I think
+ ;; it'll be a nuisance in practice if we ever want the
+ ;; compiler to be able to use WITH-COMPILATION-UNIT on
+ ;; arbitrarily huge blocks of code. -- WHN)
(let ((*compiler-error-context* node))
(compiler-note "*INLINE-EXPANSION-LIMIT* (~D) was exceeded, ~
probably trying to~% ~
(:print-object (lambda (x stream)
(print-unreadable-object (x stream :type t))))
(:copier nil))
- ;; A list of the stringified CARs of the enclosing non-original source forms
- ;; exceeding the *enclosing-source-cutoff*.
+ ;; 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.
+ ;; a list of stringified enclosing non-original source forms
(source nil :type list)
- ;; The stringified form in the original source that expanded into Source.
+ ;; 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.
+ ;; a list of prefixes of "interesting" forms that enclose original-source
(context nil :type list)
- ;; The FILE-INFO-NAME for the relevant FILE-INFO.
+ ;; 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.
+ ;; 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.
+ ;; 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
(let ((context *compiler-error-context*))
(if (compiler-error-context-p context)
context
- (let ((path (or *current-path*
+ (let ((path (or (and (boundp '*current-path*) *current-path*)
(if context
(node-source-path context)
nil))))
(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.
+;;; 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*)))
(or (cdr (assoc thing (ir2-environment-environment (environment-info env))))
(etypecase thing
(lambda-var
+ ;; I think that a failure of this assertion means that we're
+ ;; trying to access a variable which was improperly closed
+ ;; over. An ENVIRONMENT structure is a physical environment.
+ ;; Every variable that a form refers to should either be in
+ ;; its physical environment directly, or grabbed from a
+ ;; surrounding physical environment when it was closed over.
+ ;; The ASSOC expression above finds closed-over variables, so
+ ;; if we fell through the ASSOC expression, it wasn't closed
+ ;; over. Therefore, it must be in our physical environment
+ ;; directly. If instead it is in some other physical
+ ;; environment, then it's bogus for us to reference it here
+ ;; without it being closed over. -- WHN 2001-09-29
(aver (eq env (lambda-environment (lambda-var-home thing))))
(leaf-info thing))
(nlx-info
;;; 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.
+#!-gengc
(defun ir2-convert-closure (node block leaf res)
(declare (type ref node) (type ir2-block block)
(type functional leaf) (type tn res))
(vop count-me node block *dynamic-counts-tn*
(block-number (ir2-block-block block)))))
- (emit-move node block (ir2-environment-return-pc-pass env)
+ (emit-move node
+ block
+ (ir2-environment-return-pc-pass env)
(ir2-environment-return-pc env))
(let ((lab (gen-label)))
;; the transformation function. Takes the COMBINATION node and returns a
;; lambda, or throws out.
(function (required-argument) :type function)
- ;; string used in efficency notes
+ ;; string used in efficiency notes
(note (required-argument) :type string)
;; T if we should emit a failure note even if SPEED=INHIBIT-WARNINGS.
(important nil :type (member t nil))
;;; (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 policy 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.
+ ;; an alist of (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>) list, not necessarily a single symbol.
(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
;; "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
+ ;; 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
;; 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 current OPTIMIZE policy
(policy *policy* :type policy)
;; an alist of miscellaneous options that are associated with the
;; lexical environment
(options nil :type list))
+
+;;; support for the idiom (in MACROEXPAND and elsewhere) that NIL is
+;;; to be taken as a null lexical environment
+(defun coerce-to-lexenv (x)
+ (etypecase x
+ (null (make-null-lexenv))
+ (lexenv x)))
+
+;;; Is it safe to just grab the lambda expression LAMBDA in isolation,
+;;; ignoring the LEXENV?
+;;;
+;;; Note: The corresponding CMU CL code did something hairier so that
+;;; it could save inline definitions of DEFUNs in nontrivial lexical
+;;; environments. If it's ever important to try to do that, take a
+;;; look at the old CMU CL #'INLINE-SYNTACTIC-CLOSURE.
+(defun lambda-independent-of-lexenv-p (lambda lexenv)
+ (declare (type list lambda) (type lexenv lexenv))
+ (aver (eql (first lambda) 'lambda)) ; basic sanity check
+ ;; This is a trivial implementation that just makes sure that LEXENV
+ ;; doesn't have anything interesting in it. A more sophisticated
+ ;; implementation could skip things in LEXENV which aren't captured
+ ;; by LAMBDA, but this implementation doesn't try.
+ (and (null (lexenv-blocks lexenv))
+ (null (lexenv-tags lexenv))
+ (null (lexenv-variables lexenv))
+ (null (lexenv-functions lexenv))))
(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.
+;;; 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
(setup-environment-tn-conflict tn b debug-p)))))
(values))
-;;; Iterate over all the environment TNs, adding always-live conflicts as
-;;; appropriate.
+;;; 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))
(in-package "SB!C")
-;;; 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.
+;;; 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 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.
(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.
+;;; 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 tail-recursive
+;;; context. Note that any call which returns its value to a RETURN is
+;;; considered potentially tail-recursive, 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))))
\f
;;;; external entry point creation
-;;; Return a Lambda form that can be used as the definition of the XEP
+;;; 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
+;;; 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
;;; calling the entry with the appropriate prefix of the passed
;;; arguments.
;;;
-;;; If there is a more arg, then there are a couple of optimizations
+;;; 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.
;;; compared to the cost of everything else going on.
;;;
;;; Note that if policy indicates it, argument type declarations in
-;;; Fun will be verified. Since nothing is known about the type of the
+;;; 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)
(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
+;;; 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.)
+;;; 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)))
(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
+;;; 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
;;; 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
+;;; 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)
(values))
-;;; We examine all New-Functions in component, attempting to convert
+;;; 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
+;;; 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
+;;; 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
(values))
-;;; If policy is auspicious, CALL is not in an XEP, and we don't seem
+(defun local-call-analyze-until-done (clambdas)
+ (loop
+ (/show "at head of LOCAL-CALL-ANALYZE-UNTIL-DONE loop")
+ (let ((did-something nil))
+ (dolist (clambda clambdas)
+ (let* ((component (block-component (node-block (lambda-bind clambda))))
+ (*all-components* (list component)))
+ ;; The original CMU CL code seemed to implicitly assume that
+ ;; COMPONENT is the only one here. Let's make that explicit.
+ (aver (= 1 (length (functional-components clambda))))
+ (aver (eql component (first (functional-components clambda))))
+ (when (component-new-functions component)
+ (setf did-something t)
+ (local-call-analyze component))))
+ (unless did-something
+ (return))))
+ (values))
+
+;;; If policy is auspicious and 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.
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.)
+;;; Dispatch to the appropriate function to attempt to convert a call.
+;;; REF must 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.
+;;; 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.
+;;; 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
+;;; 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))
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
+;;; 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.
+;;; 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)
+
+ ;; Until sbcl-0.pre7.37.flaky5.2, we did
+ ;; (LET ((TAILS (LAMBDA-TAIL-SET FUN)))
+ ;; (SETF (TAIL-SET-FUNCTIONS TAILS)
+ ;; (DELETE FUN (TAIL-SET-FUNCTIONS TAILS))))
+ ;; (SETF (LAMBDA-TAIL-SET FUN) NIL)
+ ;; here. Apparently the idea behind the (SETF .. NIL) was that since
+ ;; TAIL-SET-FUNCTIONS no longer thinks we're in the tail set, it's
+ ;; inconsistent, and perhaps unsafe, for us to think we're in the
+ ;; tail set. Unfortunately..
+ ;;
+ ;; The (SETF .. NIL) caused problems in sbcl-0.pre7.37.flaky5.2 when
+ ;; I was trying to get Python to emit :EXTERNAL LAMBDAs directly
+ ;; (instead of only being able to emit funny little :TOP-LEVEL stubs
+ ;; which you called in order to get the address of an external LAMBDA):
+ ;; the external function was defined in terms of internal function,
+ ;; which was LET-converted, and then things blew up downstream when
+ ;; FINALIZE-XEP-DEFINITION tried to find out its DEFINED-TYPE from
+ ;; the now-NILed-out TAIL-SET. So..
+ ;;
+ ;; To deal with this problem, we no longer NIL out
+ ;; (LAMBDA-TAIL-SET FUN) here. Instead:
+ ;; * If we're the only function in TAIL-SET-FUNCTIONS, it should
+ ;; be safe to leave ourself linked to it, and vice versa.
+ ;; * If there are other functions in TAIL-SET-FUNCTIONS, then we're
+ ;; afraid of future optimizations on those functions causing
+ ;; the TAIL-SET object no longer to be valid to describe our
+ ;; return value. Thus, we delete ourselves from that object;
+ ;; but we save a copy of the object for ourselves, for the use of
+ ;; later code (e.g. FINALIZE-XEP-DEFINITION) which might want to
+ ;; know about our return type.
+ (let* ((old-tail-set (lambda-tail-set fun))
+ (old-tail-set-functions (tail-set-functions old-tail-set)))
+ (unless (= 1 (length old-tail-set-functions))
+ (setf (tail-set-functions old-tail-set)
+ (delete fun old-tail-set-functions))
+ (let ((new-tail-set (copy-tail-set old-tail-set)))
+ (setf (lambda-tail-set fun) new-tail-set
+ (tail-set-functions new-tail-set) (list fun)))))
+ ;; The documentation on TAIL-SET-INFO doesn't tell whether it
+ ;; remains valid in this case, so we nuke it on the theory that
+ ;; missing information is less dangerous than incorrect information.
+ (setf (tail-set-info (lambda-tail-set fun)) nil)
+
(let* ((home (node-home-lambda call))
(home-env (lambda-environment home)))
(push fun (lambda-lets home))
(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
;;; 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.
+;;; -- 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))
;;; 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
+;;; 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)
;;; 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
+;;; * 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
+;;; * 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
;;; 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.
+;;; * Otherwise, we must annotate the continuation for unknown values.
(defun ltn-analyze-return (node ltn-policy)
(declare (type creturn node) (type ltn-policy ltn-policy))
(let* ((cont (return-result node))
;;; 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.
+;;; 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
(declare (type component component))
(let ((2comp (component-info component)))
(do-blocks (block component)
+ ;; This assertion seems to protect us from compiling a component
+ ;; twice. As noted above, "this is where we allocate IR2-BLOCKS
+ ;; because it is the first place we need them", so if one is
+ ;; already allocated here, something is wrong. -- WHN 2001-09-14
(aver (not (block-info block)))
(let ((2block (make-ir2-block block)))
(setf (block-info block) 2block)
(block-next ,block-var)))
((eq ,block-var ,n-tail) ,result)
,@body))))
-;;; like Do-Blocks, only iterating over the blocks in reverse order
+;;; like DO-BLOCKS, only iterating over the blocks in reverse order
(defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
(unless (member ends '(nil :head :tail :both))
(error "losing ENDS value: ~S" ends))
,result)
,@body)))))
-;;; 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
+;;; 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.)
;;;
-;;; In the forward case, we terminate on Last-Cont so that we don't
+;;; 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
*last-source-form* *last-format-string* *last-format-args*
*last-message-count* *lexenv*))
-(defvar *byte-compile-default* :maybe
+;;; FIXME: byte compiler to be removed completely
+(defvar *byte-compile-default* nil
#!+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
+ |#
+ nil ; FIXME: byte compiler to be removed completely
#!+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 value of the :BYTE-COMPILE argument which was passed to the
;;; compiler
-(defvar *byte-compile* :maybe)
+(defvar *byte-compile*
+ nil #|:maybe|#) ; FIXME: byte compiler to be removed completely
;;; 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*
+;;; in which case we must look at the policy; see #'BYTE-COMPILING.
+(defvar *byte-compiling*
+ nil #|:maybe|#) ; FIXME: byte compiler to be removed completely
+
+(declaim (type (member t nil :maybe)
+ *byte-compile*
+ *byte-compiling*
*byte-compile-default*))
(defvar *check-consistency* nil)
(values))
(defun native-compile-component (component)
+ (/show "entering NATIVE-COMPILE-COMPONENT")
(let ((*code-segment* nil)
(*elsewhere* nil))
(maybe-mumble "GTN ")
;; We're done, so don't bother keeping anything around.
(setf (component-info component) nil)
+ (/show "leaving NATIVE-COMPILE-COMPONENT")
(values))
(defun policy-byte-compile-p (thing)
+ nil
+ ;; FIXME: byte compiler to be removed completely
+ #|
(policy thing
(and (zerop speed)
- (<= debug 1))))
+ (<= debug 1)))
+ |#)
;;; Return our best guess for whether we will byte compile code
;;; currently being IR1 converted. This is only a guess because the
;;; FIXME: This should be called something more mnemonic, e.g.
;;; PROBABLY-BYTE-COMPILING
(defun byte-compiling ()
+ nil
+ ;; FIXME: byte compiler to be removed completely
+ #|
(if (eq *byte-compiling* :maybe)
(or (eq *byte-compile* t)
(policy-byte-compile-p *lexenv*))
- (and *byte-compile* *byte-compiling*)))
+ (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.
-;;;
-;;; FIXME: The original CMU CL comment said "This doesn't really cover
-;;; all cases..." That's a little scary.
(defun delete-if-no-entries (component)
- (dolist (fun (component-lambdas component)
- (delete-component component))
+ (dolist (fun (component-lambdas component) (delete-component component))
+ (when (functional-has-external-references-p fun)
+ (return))
(case (functional-kind fun)
(:top-level (return))
(:external
(return))))))
(defun byte-compile-this-component-p (component)
+ nil
+ ;; FIXME: byte compiler to be removed completely
+ #|
(ecase *byte-compile*
((t) t)
((nil) nil)
((:maybe)
- (every #'policy-byte-compile-p (component-lambdas component)))))
+ (every #'policy-byte-compile-p (component-lambdas component))))
+ |#)
(defun compile-component (component)
(let* ((*component-being-compiled* component)
(file-info-source-root file-info))))
(vector-push-extend form forms)
(vector-push-extend pos (file-info-positions file-info))
- (clrhash *source-paths*)
(find-source-paths form current-idx)
(process-top-level-form form
`(original-source-start 0 ,current-idx)
(*policy* (lexenv-policy *lexenv*)))
(process-top-level-progn forms path compile-time-too))))
-;;; 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-output
- (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))))
-
;;; Parse an EVAL-WHEN situations list, returning three flags,
;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
;;; the types of situations present in the list.
(intersection '(:load-toplevel load) situations)
(intersection '(:execute eval) situations)))
+
+;;; utilities for extracting COMPONENTs of FUNCTIONALs
+(defun clambda-component (clambda)
+ (block-component (node-block (lambda-bind clambda))))
+(defun functional-components (f)
+ (declare (type functional f))
+ (etypecase f
+ (clambda (list (clambda-component f)))
+ (optional-dispatch (let ((result nil))
+ (labels ((frob (clambda)
+ (pushnew (clambda-component clambda)
+ result))
+ (maybe-frob (maybe-clambda)
+ (when maybe-clambda
+ (frob maybe-clambda))))
+ (mapc #'frob (optional-dispatch-entry-points f))
+ (maybe-frob (optional-dispatch-more-entry f))
+ (maybe-frob (optional-dispatch-main-entry f)))))))
+
+(defun make-functional-from-top-level-lambda (definition
+ &key
+ name
+ (path
+ ;; I'd thought NIL should
+ ;; work, but it doesn't.
+ ;; -- WHN 2001-09-20
+ (required-argument)))
+ (let* ((*current-path* path)
+ (component (make-empty-component))
+ (*current-component* component))
+ (setf (component-name component)
+ (format nil "~S initial component" name))
+ (setf (component-kind component) :initial)
+ (let* ((locall-fun (ir1-convert-lambda definition
+ (format nil "locall ~S" name)))
+ (fun (ir1-convert-lambda (make-xep-lambda locall-fun) name)))
+ (setf (functional-entry-function fun) locall-fun
+ (functional-kind fun) :external
+ (functional-has-external-references-p fun) t)
+ fun)))
+
+;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
+;;; description of the result.
+;;; * If *COMPILE-OBJECT* is a CORE-OBJECT, then write the function
+;;; into core and return the compiled FUNCTION value.
+;;; * If *COMPILE-OBJECT* is a fasl file, then write the function
+;;; into the fasl file and return a dump handle.
+;;;
+;;; If NAME is provided, then we try to use it as the name of the
+;;; function for debugging/diagnostic information.
+(defun %compile (lambda-expression
+ *compile-object*
+ &key
+ name
+ (path
+ ;; This magical idiom seems to be the appropriate
+ ;; path for compiling standalone LAMBDAs, judging
+ ;; from the CMU CL code and experiment, so it's a
+ ;; nice default for things where we don't have a
+ ;; real source path (as in e.g. inside CL:COMPILE).
+ '(original-source-start 0 0)))
+ (/show "entering %COMPILE" name)
+ (unless (or (null name) (legal-function-name-p name))
+ (error "not a legal function name: ~S" name))
+ (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (fun (make-functional-from-top-level-lambda lambda-expression
+ :name name
+ :path path)))
+
+ (/noshow fun)
+
+ ;; FIXME: The compile-it code from here on is sort of a
+ ;; twisted version of the code in COMPILE-TOP-LEVEL. It'd be
+ ;; better to find a way to share the code there; or
+ ;; alternatively, to use this code to replace the code there.
+ ;; (The second alternative might be pretty easy if we used
+ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+ ;; whole FUNCTIONAL-KIND=:TOP-LEVEL case could go away..)
+
+ (/show "about to LOCAL-CALL-ANALYZE-UNTIL-DONE")
+ (local-call-analyze-until-done (list fun))
+
+ (multiple-value-bind (components-from-dfo top-components hairy-top)
+ (find-initial-dfo (list fun))
+
+ (let ((*all-components* (append components-from-dfo top-components)))
+ (/noshow components-from-dfo top-components *all-components*)
+ (mapc #'preallocate-environments-for-top-levelish-lambdas
+ (append hairy-top top-components))
+ (dolist (component-from-dfo components-from-dfo)
+ (/show "compiling a COMPONENT-FROM-DFO")
+ (compile-component component-from-dfo)
+ (/show "about to REPLACE-TOP-LEVEL-XEPS")
+ (replace-top-level-xeps component-from-dfo)))
+
+ (/show "about to go into PROG1")
+ (prog1
+ (let ((entry-table (etypecase *compile-object*
+ (fasl-output (fasl-output-entry-table
+ *compile-object*))
+ (core-object (core-object-entry-table
+ *compile-object*)))))
+ (multiple-value-bind (result found-p)
+ (gethash (leaf-info fun) entry-table)
+ (aver found-p)
+ result))
+ (mapc #'clear-ir1-info components-from-dfo)
+ (clear-stuff)
+ (/show "returning from %COMPILE")))))
+
+(defun process-top-level-cold-fset (name lambda-expression path)
+ (/show "entering PROCESS-TOP-LEVEL-COLD-FSET" name)
+ (unless (producing-fasl-file)
+ (error "can't COLD-FSET except in a fasl file"))
+ (unless (legal-function-name-p name)
+ (error "not a legal function name: ~S" name))
+ (fasl-dump-cold-fset name
+ (%compile lambda-expression
+ *compile-object*
+ :name name
+ :path path)
+ *compile-object*)
+ (/show "finished with PROCESS-TOP-LEVEL-COLD-FSET" name)
+ (values))
+
;;; 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.
(car form)
form))))
(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))
+ ;; In the cross-compiler, top level COLD-FSET arranges
+ ;; for static linking at cold init time.
+ #+sb-xc-host
+ ((cold-fset)
+ (aver (not compile-time-too))
+ (destructuring-bind (cold-fset fun-name lambda-expression) form
+ (declare (ignore cold-fset))
+ (process-top-level-cold-fset fun-name
+ lambda-expression
+ path)))
((eval-when macrolet symbol-macrolet);things w/ 1 arg before body
(need-at-least-one-arg form)
(destructuring-bind (special-operator magic &rest body) form
(compile-top-level (list lambda) t)
lambda)))
-;;; Called by COMPILE-TOP-LEVEL when it was pased T for
+;;; This is called by COMPILE-TOP-LEVEL when it was passed 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
(aver (null (cdr lambdas)))
(let* ((lambda (car lambdas))
(component (block-component (node-block (lambda-bind lambda)))))
- (when (eq (component-kind component) :top-level)
+ (when (eql (component-kind component) :top-level)
(setf (component-name component) (leaf-name lambda))
(compile-component component)
(clear-ir1-info component))))
(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.
+;;; Compile LAMBDAS (a list of CLAMBDAs for top-level forms) into the
+;;; object file.
;;;
;;; 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))))
+ (local-call-analyze-until-done lambdas)
(maybe-mumble "IDFO ")
(multiple-value-bind (components top-components hairy-top)
(compile-load-time-value-lambda lambdas)
(compile-top-level-lambdas lambdas top-level-closure)))
- (dolist (component components)
- (clear-ir1-info component))
+ (mapc #'clear-ir1-info components)
(clear-stuff)))
(values))
;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
(defun sub-compile-file (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*)
+ (let* ((*block-compile* *block-compile-argument*)
(*package* (sane-package))
(*policy* *policy*)
(*lexenv* (make-null-lexenv))
;; extensions
(trace-file nil)
((:block-compile *block-compile-argument*) nil)
- ((:byte-compile *byte-compile*) *byte-compile-default*))
+ ;; FIXME: byte compiler to be removed completely
+ #+nil ((:byte-compile *byte-compile*) *byte-compile-default*))
#!+sb-doc
"Compile INPUT-FILE, producing a corresponding fasl file and returning
If given, internal data structures are dumped to the specified
file, or if a value of T is given, to a file of *.trace type
derived from the input file name.
- :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. (This option will probably become
- formally deprecated starting around sbcl-0.7.0, when various
- cleanups related to the byte interpreter are planned.)
Also, as a workaround for vaguely-non-ANSI behavior, the :BLOCK-COMPILE
argument is quasi-supported, to determine whether multiple
functions are compiled together as a unit, resolving function
;;;
;;; :Note {String | NIL}
;;; A short noun-like phrase describing what this VOP "does", i.e.
-;;; the implementation strategy. If supplied, efficency notes will
+;;; the implementation strategy. If supplied, efficiency notes will
;;; be generated when type uncertainty prevents :TRANSLATE from
-;;; working. NIL inhibits any efficency note.
+;;; working. NIL inhibits any efficiency note.
;;;
;;; :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
;;; :Result-Types {* | PType | (:OR PType*)}*
(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:
+ ;; an indication of the way that this continuation is currently used
;;
;; :UNUSED
;; A continuation for which all control-related slots have the
(flags (block-attributes reoptimize flush-p type-check type-asserted
test-modified)
:type attributes)
- ;; Some sets used by constraint propagation.
- (kill nil)
+ ;; CMU CL had a KILL slot here, documented as "set used by
+ ;; constraint propagation", which was used in constraint propagation
+ ;; as a list of LAMBDA-VARs killed, and in copy propagation as an
+ ;; SSET, representing I dunno what. I (WHN) found this confusing,
+ ;; and furthermore it caused type errors when I was trying to make
+ ;; the compiler produce fully general LAMBDA functions directly
+ ;; (instead of doing as CMU CL always did, producing extra little
+ ;; functions which return the LAMDBA you need) and therefore taking
+ ;; a new path through the compiler. So I split this into two:
+ ;; KILL-LIST = list of LAMBDA-VARs killed, used in constraint propagation
+ ;; KILL-SSET = an SSET value, used in copy propagation
+ (kill-list nil :type list)
+ (kill-sset nil :type (or sset null))
+ ;; other sets used in constraint propagation and/or copy propagation
(gen nil)
(in nil)
(out nil)
;; 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.
+ ;; 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.
(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
+;;; The BLOCK-ANNOTATION class is inherited (via :INCLUDE) by
+;;; different BLOCK-INFO annotation structures so that code
;;; (specifically control analysis) can be shared.
(defstruct (block-annotation (:constructor nil)
(:copier nil))
(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
+;;; A 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.
+;;; COMPONENTs rather than on the entire flow graph.
(defstruct (component (:copier nil))
- ;; The kind of component:
- ;;
- ;; NIL
- ;; An ordinary component, containing non-top-level code.
+ ;; the kind of component
;;
- ;; :Top-Level
- ;; A component containing only load-time code.
+ ;; (The terminology here is left over from before
+ ;; sbcl-0.pre7.34.flaky5.2, when there was no such thing as
+ ;; FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P, so that Python was
+ ;; incapable of building standalone :EXTERNAL functions, but instead
+ ;; had to implement things like #'CL:COMPILE as FUNCALL of a little
+ ;; toplevel stub whose sole purpose was to return an :EXTERNAL
+ ;; function.)
;;
- ;; :Complex-Top-Level
- ;; A component containing both top-level and run-time code.
+ ;; The possibilities are:
+ ;; NIL
+ ;; an ordinary component, containing non-top-level code
+ ;; :TOP-LEVEL
+ ;; a component containing only load-time code
+ ;; :COMPLEX-TOP-LEVEL
+ ;; In the old system, before FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P
+ ;; was defined, this was necessarily a component containing both
+ ;; top-level and run-time code. Now this state is also used for
+ ;; a component with HAS-EXTERNAL-REFERENCES-P functionals in it.
+ ;; :INITIAL
+ ;; the result of initial IR1 conversion, on which component
+ ;; analysis has not been done
+ ;; :DELETED
+ ;; debris left over from component analysis
;;
- ;; :Initial
- ;; The result of initial IR1 conversion, on which component
- ;; analysis has not been done.
- ;;
- ;; :Deleted
- ;; Debris left over from component analysis.
+ ;; See also COMPONENT-TOP-LEVELISH-P.
(kind nil :type (member nil :top-level :complex-top-level :initial :deleted))
- ;; The blocks that are the dummy head and tail of the DFO.
+ ;; 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.)
+ ;; (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.
+ ;; This becomes 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.
+ ;;
+ ;; Note that logical associations between CLAMBDAs and COMPONENTs
+ ;; seem to exist for a while before this is initialized. In
+ ;; particular, I got burned by writing some code to use this value
+ ;; to decide which components need LOCAL-CALL-ANALYZE, when it turns
+ ;; out that LOCAL-CALL-ANALYZE had a role in initializing this value
+ ;; (and DFO stuff does too, maybe). Also, even after it's
+ ;; initialized, it might change as CLAMBDAs are deleted or merged.
+ ;; -- WHN 2001-09-30
(lambdas () :type list)
- ;; A list of Functional structures for functions that are newly
+ ;; 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
+ ;; 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.
+ ;; If this is 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.
+ ;; If this is true, then the control flow in this component was
+ ;; messed up by IR1 optimizations, so the DFO should be recomputed.
(reanalyze nil :type boolean)
- ;; String that is some sort of name for the code in this component.
+ ;; some sort of name for the code in this component
(name "<unknown>" :type simple-string)
- ;; Some kind of info used by the back end.
+ ;; some kind of info used by the back end
(info nil)
- ;; The Source-Info structure describing where this component was
- ;; compiled from.
+ ;; 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
+ ;; count of the number of inline expansions we have done while
;; compiling this component, to detect infinite or exponential
- ;; blowups.
+ ;; 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
+ ;; a map from combination nodes to things describing how an
+ ;; optimization of the node failed. The description 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
+ ;; This is 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)
+(defprinter (component :identity t)
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.
+;;; Before sbcl-0.7.0, there were :TOP-LEVEL things which were magical
+;;; in multiple ways. That's since been refactored into the orthogonal
+;;; properties "optimized for locall with no arguments" and "externally
+;;; visible/referenced (so don't delete it)". The code <0.7.0 did a lot
+;;; of tests a la (EQ KIND :TOP_LEVEL) in the "don't delete it?" sense;
+;;; this function is a sort of literal translation of those tests into
+;;; the new world.
+;;;
+;;; FIXME: After things settle down, bare :TOP-LEVEL might go away, at
+;;; which time it might be possible to replace the COMPONENT-KIND
+;;; :TOP-LEVEL mess with a flag COMPONENT-HAS-EXTERNAL-REFERENCES-P
+;;; along the lines of FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P.
+(defun lambda-top-levelish-p (clambda)
+ (or (eql (lambda-kind clambda) :top-level)
+ (lambda-has-external-references-p clambda)))
+(defun component-top-levelish-p (component)
+ (member (component-kind component)
+ '(:top-level :complex-top-level)))
+
+;;; A 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
+;;; 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 (:copier nil))
- ;; The kind of thing that has to be cleaned up.
+ ;; 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
+ ;; 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
+ ;; 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)
+(defprinter (cleanup :identity t)
kind
mess-up
(nlx-info :test nlx-info))
-;;; The ENVIRONMENT structure represents the result of environment analysis.
+;;; original CMU CL comment:
+;;; An ENVIRONMENT structure represents the result of environment
+;;; analysis.
+;;;
+;;; As far as I can tell from reverse engineering, this IR1 structure
+;;; represents the physical environment (which is probably not the
+;;; standard Lispy term for this concept, but I dunno what is the
+;;; standard term): those things in the lexical environment which a
+;;; LAMBDA actually interacts with. Thus in
+;;; (DEFUN FROB-THINGS (THINGS)
+;;; (DOLIST (THING THINGS)
+;;; (BLOCK FROBBING-ONE-THING
+;;; (MAPCAR (LAMBDA (PATTERN)
+;;; (WHEN (FITS-P THING PATTERN)
+;;; (RETURN-FROM FROB-THINGS (LIST :FIT THING PATTERN))))
+;;; *PATTERNS*))))
+;;; the variables THINGS, THING, and PATTERN and the block names
+;;; FROB-THINGS and FROBBING-ONE-THING are all in the inner LAMBDA's
+;;; lexical environment, but of those only THING, PATTERN, and
+;;; FROB-THINGS are in its physical environment. In IR1, we largely
+;;; just collect the names of these things; in IR2 an IR2-ENVIRONMENT
+;;; structure is attached to INFO and used to keep track of
+;;; associations between these names and less-abstract things (like
+;;; TNs, or eventually stack slots and registers). -- WHN 2001-09-29
(defstruct (environment (:copier nil))
;; 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
+ ;; This ultimately converges to a list of all the LAMBDA-VARs and
+ ;; NLX-INFOs needed from enclosing environments by code in this
+ ;; environment. In the meantime, it may be
+ ;; * NIL at object creation time
+ ;; * a superset of the correct result, generated somewhat later
+ ;; * smaller and smaller sets converging to the correct result as
+ ;; we notice and delete unused elements in the superset
(closure nil :type list)
- ;; a list of NLX-Info structures describing all the non-local exits
+ ;; 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)
+(defprinter (environment :identity t)
function
(closure :test closure)
(nlx-info :test nlx-info))
-;;; The TAIL-SET structure is used to accumulate information about
+;;; An TAIL-SET structure is used to accumulate information about
;;; tail-recursive local calls. The "tail set" is effectively the
;;; transitive closure of the "is called tail-recursively by"
;;; relation.
;;; 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 (:copier nil))
- ;; a list of all the lambdas in this tail set
+;;; be sure which calls will be tail-recursive. Any call that *might*
+;;; end up tail-recursive 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.
+ ;; RESULT-TYPE, excluding local calls.
(type *wild-type* :type ctype)
;; some info used by the back end
(info nil))
-(defprinter (tail-set)
+(defprinter (tail-set :identity t)
functions
type
(info :test info))
(target nil :type (or cblock null))
;; some kind of info used by the back end
info)
-(defprinter (nlx-info)
+(defprinter (nlx-info :identity t)
continuation
target
info)
(def!struct (constant (:include leaf))
;; the value of the constant
(value nil :type t))
-(defprinter (constant)
+(defprinter (constant :identity t)
(name :test name)
value)
;; kind of variable described
(kind (required-argument)
:type (member :special :global-function :constant :global)))
-(defprinter (global-var)
+(defprinter (global-var :identity t)
name
(type :test (not (eq type *universal-type*)))
(where-from :test (not (eq where-from :assumed)))
(for (required-argument) :type sb!xc:class)
;; The slot description of the slot.
(slot (required-argument)))
-(defprinter (slot-accessor)
+(defprinter (slot-accessor :identity t)
name
for
slot)
;; 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)
+(defprinter (defined-function :identity t)
name
inlinep
(functional :test functional))
;; 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.
+ ;; 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.
+ ;; for is in the ENTRY-FUNCTION slot.
;;
;; :TOP-LEVEL
;; a top-level lambda, holding a compiled top-level form.
;; :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
+ (kind nil :type (member nil :optional :deleted :external :top-level
+ :escape :cleanup :let :mv-let :assignment
:top-level-xep))
+ ;; Is this a function that some external entity (e.g. the fasl dumper)
+ ;; refers to, so that even when it appears to have no references, it
+ ;; shouldn't be deleted? In the old days (before
+ ;; sbcl-0.pre7.37.flaky5.2) this was sort of implicitly true when
+ ;; KIND was :TOP-LEVEL. Now it must be set explicitly, both for
+ ;; :TOP-LEVEL functions and for any other kind of functions that we
+ ;; want to dump or return from #'CL:COMPILE or whatever.
+ (has-external-references-p nil)
;; 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
+ ;; 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.
+ ;; :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))
(arg-documentation nil :type (or list (member :unspecified)))
;; various rare miscellaneous info that drives code generation & stuff
(plist () :type list))
-(defprinter (functional)
+(defprinter (functional :identity t)
name)
;;; The CLAMBDA only deals with required lexical arguments. Special,
(:predicate lambda-p)
(:constructor make-lambda)
(:copier copy-lambda))
- ;; List of lambda-var descriptors for args.
+ ;; 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.
+ ;; 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 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.
+ ;; semantics within the flow graph representation. This is null in
+ ;; deleted functions, and also in LETs where we deleted the call and
+ ;; 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.
+ ;; 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
+ ;; 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.
+ ;; If this CLAMBDA is a LET, then this slot holds the LAMBDA whose
+ ;; LETS list we are in, otherwise it is a self-pointer.
(home nil :type (or clambda null))
- ;; A list of all the all the lambdas that have been let-substituted
+ ;; 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.
(lets () :type list)
- ;; A list of all the Entry nodes in this function and its lets. Null
- ;; an a let.
+ ;; a list of all the ENTRY nodes in this function and its LETs, or
+ ;; null in 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
+ ;; a list of all the functions directly called from this function
+ ;; (or one of its LETs) using a non-LET local call. This 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.
+ ;; the TAIL-SET that this LAMBDA is in. This is null during creation.
+ ;;
+ ;; In CMU CL, and old SBCL, this was also NILed out when LET
+ ;; conversion happened. That caused some problems, so as of
+ ;; sbcl-0.pre7.37.flaky5.2 when I was trying to get the compiler to
+ ;; emit :EXTERNAL functions directly, and so now the value
+ ;; is no longer NILed out in LET conversion, but instead copied
+ ;; (so that any further optimizations on the rest of the tail
+ ;; set won't modify the value) if necessary.
(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
+ ;; 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),
+ ;; 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-)
+(defprinter (clambda :conc-name lambda- :identity t)
name
(type :test (not (eq type *universal-type*)))
(where-from :test (not (eq where-from :assumed)))
;;; 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
+;;; 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
+;;; 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
;; 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 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
+ ;; 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
+ ;; 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)
+(defprinter (optional-dispatch :identity t)
name
(type :test (not (eq type *universal-type*)))
(where-from :test (not (eq where-from :assumed)))
;; the actual key for a &KEY argument. Note that in ANSI CL this is not
;; necessarily a keyword: (DEFUN FOO (&KEY ((BAR BAR))) ..).
(key nil :type symbol))
-(defprinter (arg-info)
+(defprinter (arg-info :identity t)
(specialp :test specialp)
kind
(supplied-p :test supplied-p)
;; 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)
+(defprinter (lambda-var :identity t)
name
(type :test (not (eq type *universal-type*)))
(where-from :test (not (eq where-from :assumed)))
(:copier nil))
;; The leaf referenced.
(leaf nil :type leaf))
-(defprinter (ref)
+(defprinter (ref :identity t)
leaf)
;;; Naturally, the IF node always appears at the end of a block.
;; respectively (may be the same)
(consequent (required-argument) :type cblock)
(alternative (required-argument) :type cblock))
-(defprinter (cif :conc-name if-)
+(defprinter (cif :conc-name if- :identity t)
(test :prin1 (continuation-use test))
consequent
alternative)
(var (required-argument) :type basic-var)
;; continuation for the value form
(value (required-argument) :type continuation))
-(defprinter (cset :conc-name set-)
+(defprinter (cset :conc-name set- :identity t)
var
(value :prin1 (continuation-use value)))
(defstruct (combination (:include basic-combination)
(:constructor make-combination (fun))
(:copier nil)))
-(defprinter (combination)
+(defprinter (combination :identity t)
(fun :prin1 (continuation-use fun))
(args :prin1 (mapcar (lambda (x)
(if x
;; asserted-type. If there are no non-call uses, this is
;; *EMPTY-TYPE*
(result-type *wild-type* :type ctype))
-(defprinter (creturn :conc-name return-)
+(defprinter (creturn :conc-name return- :identity t)
lambda
result-type)
\f
(exits nil :type list)
;; The cleanup for this entry. NULL only temporarily.
(cleanup nil :type (or cleanup null)))
-(defprinter (entry))
+(defprinter (entry :identity t))
;;; The EXIT node marks the place at which exit code would be emitted,
;;; if necessary. This is interposed between the uses of the exit
;; 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)
+(defprinter (exit :identity t)
(entry :test entry)
(value :test value))
\f
(unless (csubtypep type (specifier-type 'function))
(error "not a function type: ~S" (first args)))
(dolist (name (rest args))
- (cond ((info :function :accessor-for name)
- ;; FIXME: This used to be a WARNING, which was
- ;; clearly wrong, since it would cause warnings to
- ;; be issued for conforming code, which is really
- ;; annoying for people who use Lisp code to build
- ;; Lisp systems (and check the return values from
- ;; COMPILE and COMPILE-FILE). Changing it to a
- ;; compiler note is somewhat better, since it's
- ;; after all news about a limitation of the
- ;; compiler, not a problem in the code. But even
- ;; better would be to handle FTYPE proclamations
- ;; for slot accessors, and since in the long run
- ;; slot accessors should become more like other
- ;; functions, this should eventually become
- ;; straightforward.
- (maybe-compiler-note
- "~@<ignoring FTYPE proclamation for ~
- slot accessor (currently unsupported): ~2I~_~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)))))
+ ;; 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
+ #|
+ (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)))))
+ |#
+
+ ;; Now references to this function shouldn't be warned
+ ;; about as undefined, since even if we haven't seen a
+ ;; definition yet, we know one is planned. (But if this
+ ;; function name was already declared as a structure
+ ;; accessor, then that was already been taken care of.)
+ (unless (info :function :accessor-for name)
+ (proclaim-as-function-name name)
+ (note-name-defined name :function))
- (proclaim-as-function-name name)
- (note-name-defined name :function)
- (setf (info :function :type name) type
- (info :function :where-from name) :declared)))))))
+ ;; the actual type declaration
+ (setf (info :function :type name) type
+ (info :function :where-from name) :declared)))))
(freeze-type
(dolist (type args)
(let ((class (specifier-type type)))
;;; 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.
+;;; 6. True if the costs or SCs in the VOP-INFO are inconsistent with
+;;; the currently recorded ones.
(defun get-operand-info (ref)
(declare (type tn-ref ref))
(let* ((arg-p (not (tn-ref-write-p ref)))
(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.
+;;; 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))
(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.
+;;; 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))
\f
;;;; VM consistency checking
;;;;
-;;;; We do some checking of the consistency of the VM definition at load
-;;;; time.
+;;;; 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 ()
(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.
+;;; 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))
(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.
+;;; 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))
(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.
+;;; 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)))
(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.
+;;; 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.
+;;; 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)
: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.
+;;; 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.
+;;; 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.
+;;; 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.
+;;; 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))
(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.
+;;; 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)
(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.)
+;;; 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))
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.
+;;; 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)
(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.
+;;; 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))
(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.
+;;; This is the 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)))
;;; 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.
+;;; handle that case, otherwise give an efficiency note.
(deftransform eql ((x y) * * :when :both)
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
(and (subtypep coerced-type 'integer)
(csubtypep value-type (specifier-type 'integer))))))
(process-types (type)
- ;; FIXME
+ ;; FIXME:
;; This needs some work because we should be able to derive
;; the resulting type better than just the type arg of
;; coerce. That is, if x is (integer 10 20), the (coerce x
(in-package "SB!C")
-;;; Each structure that may be placed in a SSet must include the
-;;; SSet-Element structure. We allow an initial value of NIL to mean
+;;; 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)
(:copier nil))
(number nil :type (or index null)))
-(defstruct (sset (:constructor make-sset ()))
- (elements (list nil) :type list))
+(defstruct (sset (:copier nil))
+ ;; The element at the head of the list here seems always to be
+ ;; ignored. I think this idea is that the extra level of indirection
+ ;; it provides is handy to allow various destructive operations on
+ ;; SSETs to be expressed more easily. -- WHN
+ (elements (list nil) :type cons))
(defprinter (sset)
(elements :prin1 (cdr elements)))
(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,
+;;; 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)
(setf (cdr prev) (cons element current))
(return t))))))
-;;; Destructively remove Element from Set. If element was in the set,
+;;; 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)
(setf (cdr prev) (cdr current))
(return t)))))
-;;; Return true if Element is in Set, false otherwise.
+;;; 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))
;;; 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))
+ (make-sset :elements (copy-list (sset-elements set))))
-;;; Perform the appropriate set operation on SET1 and SET2 by destructively
-;;; modifying SET1. We return true if SET1 was modified, false otherwise.
+;;; 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)
(if (> num1 num2)
(let ((new (cons e el1)))
(setf (cdr prev-el1) new)
- (setq prev-el1 new changed t))
+ (setq prev-el1 new
+ changed t))
(shiftf prev-el1 el1 (cdr el1)))
(return))
(shiftf prev-el1 el1 (cdr el1))))))))
(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
+;;; 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)
(in-package "SB!C")
-;;; Generate trace-file output for the byte compiler back-end.
+;;; 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
(type (member t nil) use-labels))
(pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
(let ((fun (compiled-function-or-lose object)))
- (if (typep fun 'sb!kernel:byte-function)
+ (if nil #|(typep fun 'sb!kernel:byte-function)|# ; FIXME: byte compile to go away completely
(sb!c:disassem-byte-fun fun)
;; We can't detect closures, so be careful.
(disassemble-function (fun-self fun)
(dump-unsigned-32 mid-bits file)
(dump-unsigned-32 high-bits file)
(dump-integer-as-n-bytes exp-bits 4 file)))
-
-(defun dump-complex (x file)
- (typecase x
- ((complex single-float)
- (dump-fop '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 '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 '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 'fop-complex file))))
\f
;;;; dumping things which don't exist in portable ANSI Common Lisp
+;;; FIXME: byte compiler to go away completely
+#|
;;; 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.
(dump-fop 'fop-make-byte-compiled-function file)
(dump-byte nslots file))
(values))
+|#
\ No newline at end of file
\f
;;;; CL:COMPILE
-(defun get-lambda-to-compile (definition)
- (if (consp definition)
- definition
- (multiple-value-bind (def env-p)
- (function-lambda-expression definition)
+(defun get-lambda-to-compile (definition-designator)
+ (if (consp definition-designator)
+ definition-designator
+ (multiple-value-bind (definition env-p)
+ (function-lambda-expression definition-designator)
(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)))
+ (error "~S was defined in a non-null environment."
+ definition-designator))
+ (unless definition
+ (error "can't find a definition for ~S" definition-designator))
+ definition)))
-;;; 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.
+;;; 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
(defun actually-compile (name definition)
(with-compilation-values
(sb!xc:with-compilation-unit ()
- (let* (;; FIXME: Do we need this rebinding here? It's a literal
- ;; translation of the old CMU CL rebinding to
- ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
- ;; and it's not obvious whether the rebinding to itself is
- ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
+ ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
+ ;; few changes. Once things are stable, the shared bindings
+ ;; probably be merged back together into some shared utility
+ ;; macro, or perhaps both merged into one of the existing utility
+ ;; macros SB-C::WITH-COMPILATION-VALUES or
+ ;; CL:WITH-COMPILATION-UNIT.
+ (let* (;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding
+ ;; here? It's a literal translation of the old CMU CL
+ ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT*
+ ;; *INFO-ENVIRONMENT*), and it's not obvious whether the
+ ;; rebinding to itself is needed now that SBCL doesn't
+ ;; need *BACKEND-INFO-ENVIRONMENT*.
(*info-environment* *info-environment*)
(*lexenv* (make-null-lexenv))
- (form `#',(get-lambda-to-compile definition))
+ (form (get-lambda-to-compile definition))
(*source-info* (make-lisp-source-info form))
(*top-level-lambdas* ())
(*block-compile* 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
(*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 ((compiled-fun (core-call-top-level-lambda lambda
- *compile-object*)))
- (fix-core-source-info *source-info* *compile-object* compiled-fun)
- compiled-fun))))))
+ (%compile form (make-core-object)
+ :name name
+ :path '(original-source-start 0 0))))))
(defun compile (name &optional (definition (fdefinition name)))
#!+sb-doc
\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.
+;;; 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))
;; 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.
+;;; An IR2-ENVIRONMENT is used to annotate non-LET LAMBDAs with their
+;;; passing locations. It is stored in the ENVIRONMENT-INFO.
(defstruct (ir2-environment (:copier nil))
;; the TNs that hold the passed environment within the function.
- ;; This is an alist translating from the NLX-Info or lambda-var to
+ ;; 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 elements of this list correspond to the elements of the list
+ ;; in the CLOSURE slot of the ENVIRONMENT object that links to us:
+ ;; essentially this list is related to the CLOSURE list by MAPCAR.
+ (environment (required-argument) :type list :read-only t)
;; 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
+ ;; 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)
+ (return-pc-pass (required-argument) :type tn :read-only t)
;; 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.
(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
+ ;; a label that marks the start of elsewhere code for this function,
+ ;; or 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
(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.
+ ;; targeting. This is done by modifying 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.)
+ ;; is called with the VOP structure. This is null if this VOP has no
+ ;; specified generator (i.e. if 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
;;
;; :SAVE
;; :SAVE-ONCE
- ;; A TN used for saving a :Normal TN across function calls. The
+ ;; 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
+ ;; 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
;; determination method.
;;
;; :CONSTANT
- ;; Represents a constant, with TN-Leaf a Constant leaf. Lifetime
+ ;; 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.
+ ;; 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
(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.
+ ;; 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.
;;; classes has been defined, the real definition of LOAD-DEFCLASS is
;;; installed by the file std-class.lisp
(defmacro defclass (name %direct-superclasses %direct-slots &rest %options)
- (setq supers (copy-tree %direct-superclasses)
- slots (copy-tree %direct-slots)
- options (copy-tree %options))
- (let ((metaclass 'standard-class))
- (dolist (option options)
- (if (not (listp option))
+ (let ((supers (copy-tree %direct-superclasses))
+ (slots (copy-tree %direct-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))
legal class name."
(cadr option)))
(setq metaclass
- (case (cadr option)
- (cl:standard-class 'standard-class)
- (cl:structure-class 'structure-class)
- (t (cadr option))))
+ (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* ())
- (*readers* ()) ;Truly a crock, but we got
- (*writers* ())) ;to have it to live nicely.
- (declare (special *initfunctions* *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))
- ;; FIXME: What does this flag mean?
- (defstruct-p (and (eq *boot-state* 'complete)
- (let ((mclass (find-class metaclass nil)))
- (and mclass
- (*subtypep
- mclass
- *the-class-structure-class*))))))
- (let ((defclass-form
- `(progn
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t) t) ,x)))
- *readers*)
- ,@(mapcar (lambda (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)))))))
- (if defstruct-p
- (progn
- ;; FIXME: The ANSI way to do this is with EVAL-WHEN
- ;; forms, not by side-effects at macroexpansion time.
- ;; But I (WHN 2001-09-02) am not even sure how to
- ;; reach this code path with ANSI (or art-of-the-MOP)
- ;; code, so I haven't tried to update it, since for
- ;; all I know maybe it could just be deleted instead.
- (eval defclass-form) ; Define the class now, so that..
- `(progn ; ..the defstruct can be compiled.
- ,(class-defstruct-form (find-class name))
- ,defclass-form))
+ (let ((*initfunctions* ())
+ (*readers* ()) ;Truly a crock, but we got
+ (*writers* ())) ;to have it to live nicely.
+ (declare (special *initfunctions* *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 should be true, if the class is defined with a
+ ;; metaclass STRUCTURE-CLASS, such that a DEFSTRUCT is compiled
+ ;; for the class.
+ (defstruct-p (and (eq *boot-state* 'complete)
+ (let ((mclass (find-class metaclass nil)))
+ (and mclass
+ (*subtypep
+ mclass
+ *the-class-structure-class*))))))
+ (let ((defclass-form
+ `(progn
+ ,@(mapcar (lambda (x)
+ `(declaim (ftype (function (t) t) ,x)))
+ *readers*)
+ ,@(mapcar (lambda (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)))))))
+ (if defstruct-p
+ (let* ((include (or (and supers
+ (fix-super (car supers)))
+ (and (not (eq name 'structure-object))
+ *the-class-structure-object*)))
+ (defstruct-form (make-structure-class-defstruct-form name
+ slots
+ include)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ ,defstruct-form) ; really compile the defstruct-form
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ ,defclass-form)))
`(progn
- ;; By telling the type system at compile time about
- ;; the existence of a class named NAME, we can avoid
- ;; various bogus warnings about "type isn't defined yet".
- ,(when (and
+ ;; By telling the type system at compile time about
+ ;; the existence of a class named NAME, we can avoid
+ ;; various bogus warnings about "type isn't defined yet".
+ ,(when (and
;; But it's not so important to get rid of
;; "not defined yet" warnings during
;; bootstrapping, and machinery like
;; time; we don't in general know how to do
;; that for other classes. So punt then too.
(eq metaclass 'standard-class))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (inform-type-system-about-std-class ',name)))
- ,defclass-form)))))))
+ `(eval-when (:compile-toplevel)
+ ;; we only need :COMPILE-TOPLEVEL here, because this
+ ;; should happen in the compile-time environment
+ ;; only.
+ ;; Later, INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS is
+ ;; called by way of LOAD-DEFCLASS (calling
+ ;; ENSURE-CLASS-USING-CLASS) to establish the 'real'
+ ;; type predicate.
+ (inform-type-system-about-std-class ',name)))
+ ,defclass-form))))))))
(defun make-initfunction (initform)
(declare (special *initfunctions*))
(non-setf-var . non-setf-case))
`(let ((,non-setf-var ,spec)) ,@non-setf-case))
-;;; 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.
+;;; If symbol names a function which is traced, return the untraced
+;;; definition. This lets us get at the generic function object even
+;;; when it is traced.
(defun unencapsulated-fdefinition (symbol)
(fdefinition symbol))
-;;; If symbol names a function which is traced or advised, redefine
-;;; the `real' definition without affecting the advise.
+;;; If symbol names a function which is traced, redefine the `real'
+;;; definition without affecting the trace.
(defun fdefine-carefully (name new-definition)
(progn
- (sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
(setf (fdefinition name) new-definition))
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (/noshow "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))))
- (/show inherits)
+ (/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
(collect ((res))
(let ((subs (sb-kernel:class-subclasses class)))
- (/show subs)
+ (/noshow subs)
(when subs
(dohash (sub v subs)
(declare (ignore v))
- (/show sub)
+ (/noshow sub)
(when (member class (direct-supers sub))
(res sub)))))
(res)))
;; relevant cases.
42))))
(mapcar (lambda (kernel-bic-entry)
- (/show "setting up" kernel-bic-entry)
+ (/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
(class (cl:find-class name)))
- (/show name class)
+ (/noshow name class)
`(,name
,(mapcar #'cl:class-name (direct-supers class))
,(mapcar #'cl:class-name (direct-subs class))
sb-kernel:funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
-(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
(typep fcn 'generic-function)
(eq (class-of fcn) *the-class-standard-generic-function*))
(setf (sb-kernel:%funcallable-instance-info fcn 1) new-name)
+ (error 'simple-type-error
+ :datum fcn
+ :expected-type 'generic-function
+ :format-control "internal error: unexpected function type")
+ ;; FIXME: byte compiler to go away completely
+ #|
(etypecase 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))))
+ (setf (sb-kernel:byte-function-name fcn) new-name)))
+ |#
+ )
fcn)
(t
;; pw-- This seems wrong and causes trouble. Tests show
(unless (constantp slot-name)
(error "~S requires its slot-name argument to be a constant"
'accessor-slot-boundp))
- (let* ((slot-name (eval slot-name)))
+ (let ((slot-name (eval slot-name)))
`(slot-boundp-normal ,object ',slot-name)))
(defun structure-slot-boundp (object)
(defmethod class-predicate-name ((class t))
'constantly-nil)
+(defun 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))))))
+
(defun ensure-class-values (class args)
(let* ((initargs (copy-list args))
(unsupplied (list 1))
*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)))))
+ (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
(defmethod shared-initialize :after
(unless (eq allocation :instance)
(error "Structure slots must have :INSTANCE allocation.")))
+(defun make-structure-class-defstruct-form
+ (name direct-slots include)
+ (let* ((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 ())
+ (:copier nil))
+ ,@(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
+ (cons nil nil))))
+ (values defstruct-form constructor reader-names writer-names)))
+
(defmethod shared-initialize :after
((class structure-class)
slot-names
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 ())
- (:copier nil))
- ,@(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
- (cons 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
+ (let ((include (car (slot-value class 'direct-superclasses))))
+ (multiple-value-bind (defstruct-form constructor reader-names writer-names)
+ (make-structure-class-defstruct-form name direct-slots include)
+ (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))
+ (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))
-
+ (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))
;; environment. So we just blow it off, 'cause anything real we do
;; would be wrong. But we still have to make an entry so we can tell
;; functions from macros.
- (let ((env (or env (sb-kernel:make-null-lexenv))))
+ (let ((lexenv (sb-kernel::coerce-to-lexenv env)))
(sb-c::make-lexenv
- :default env
+ :default lexenv
:functions
(append (mapcar (lambda (f)
- (cons (car f) (sb-c::make-functional :lexenv env)))
+ (cons (car f) (sb-c::make-functional :lexenv lexenv)))
functions)
(mapcar (lambda (m)
(list* (car m)
("src/code/setf-funs" :not-host)
+ ("src/code/stubs" :not-host)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compiler (and a few miscellaneous files whose dependencies make it
;;; convenient to stick them here)
("src/code/load")
- ("src/code/fop") ; needs macros from code/host-load.lisp
+ ("src/code/fop") ; needs macros from code/load.lisp
("src/compiler/ctype")
("src/compiler/disassem")
;; host, because fundamental BYTE-FUNCTION-OR-CLOSURE types are
;; implemented as FUNCALLABLE-INSTANCEs, and it's not obvious how to
;; emulate those in a vanilla ANSI Common Lisp.
+ #| ; FIXME: byte compiler to go away completely
("src/code/byte-types" :not-host)
("src/compiler/byte-comp")
("src/compiler/target-byte-comp" :not-host)
("src/code/byte-interp" :not-host) ; needs byte-comp *SYSTEM-CONSTANT-CODES*
+ |#
;; defines SB!DI:DO-DEBUG-FUNCTION-BLOCKS, needed by target-disassem.lisp
("src/code/debug-int" :not-host)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+;;; FIXME: Bug 126 isn't dead yet..
+#|
+;;; Array initialization has complicated defaulting for :ELEMENT-TYPE,
+;;; and both compile-time and run-time logic takes a whack at it.
+(let ((testcases '(;; Bug 126, confusion between high-level default string
+ ;; initial element #\SPACE and low-level default array
+ ;; element #\NULL, is gone.
+ (#\space (make-array 11 :element-type 'character))
+ (#\space (make-string 11 :initial-element #\space))
+ (#\space (make-string 11))
+ (#\null (make-string 11 :initial-element #\null))
+ (#\x (make-string 11 :initial-element #\x))
+ ;; And the other tweaks made when fixing bug 126 didn't
+ ;; mess things up too badly either.
+ (nil (make-array 11))
+ (nil (make-array 11 :initial-element nil))
+ (12 (make-array 11 :initial-element 12))
+ (0 (make-array 11 :element-type '(unsigned-byte 4)))
+ (12 (make-array 11
+ :element-type '(unsigned-byte 4)
+ :initial-element 12)))))
+ (dolist (testcase testcases)
+ (destructuring-bind (expected-result form) testcase
+ (unless (eql expected-result (aref (eval form) 3))
+ (error "expected ~S in EVAL ~S" expected-result form))
+ (unless (eql expected-result (aref (funcall (compile nil form)) 3))
+ (error "expected ~S in FUNCALL COMPILE ~S" expected-result form)))))
+|#
\ No newline at end of file
(format t "~&No applicable method for ZUT-N-A-M ~S, yet.~%" args))
(zut-n-a-m 1 2 3)
\f
+
+;; structure-class tests setup
+(defclass structure-class-foo1 () () (:metaclass cl:structure-class))
+(defclass structure-class-foo2 (structure-class-foo1)
+ () (:metaclass cl:structure-class))
+
+;; standard-class tests setup
+(defclass standard-class-foo1 () () (:metaclass cl:standard-class))
+(defclass standard-class-foo2 (standard-class-foo1)
+ () (:metaclass cl:standard-class))
+
+
+(assert (typep (class-of (make-instance 'structure-class-foo1))
+ 'structure-class))
+(assert (typep (make-instance 'structure-class-foo1) 'structure-class-foo1))
+(assert (typep (make-instance 'standard-class-foo1) 'standard-class-foo1))
+
;;;; success
(sb-ext:quit :unix-status 104)
ld -shared -o $testfilestem.so $testfilestem.o
${SBCL:-sbcl} <<EOF
- (when (fboundp 'load-foreign) ; not necessarily supported on all OSes..
- (load-foreign '("$testfilestem.so"))
- (def-alien-routine summish int (x int) (y int))
- (assert (= (summish 10 20) 31)))
+ (unless (fboundp 'load-foreign) ; not necessarily supported on all OSes..
+ (sb-ext:quit :unix-status 52)) ; successfully unsupported:-|
+ (load-foreign '("$testfilestem.so"))
+ (def-alien-routine summish int (x int) (y int))
+ (assert (= (summish 10 20) 31))
(sb-ext:quit :unix-status 52) ; success convention for Lisp program
EOF
if [ $? != 52 ]; then
(assert (subtypep 'ratio 'real))
(assert (subtypep 'ratio 'number))
\f
-;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to allow
-;;;; inline type tests for CONDITIONs and STANDARD-OBJECTs, and generally
-;;;; be nicer, and Martin Atzmueller ported the patches.
-;;;; They look nice but they're nontrivial enough that it's not obvious
-;;;; from inspection that everything is OK. Let's make sure that things
-;;;; still basically work.
+;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
+;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
+;;;; generally be nicer, and Martin Atzmueller ported the patches.
+;;;; They look nice but they're nontrivial enough that it's not
+;;;; obvious from inspection that everything is OK. Let's make sure
+;;;; that things still basically work.
;; structure type tests setup
(defstruct structure-foo1)
;; structure type tests
(assert (typep (make-structure-foo3) 'structure-foo2))
(assert (not (typep (make-structure-foo1) 'structure-foo4)))
+ (assert (typep (nth-value 1
+ (ignore-errors (structure-foo2-x
+ (make-structure-foo1))))
+ 'type-error))
(assert (null (ignore-errors
(setf (structure-foo2-x (make-structure-foo1)) 11))))
(sb-pcl:class-direct-subclasses (sb-pcl:find-class
'simple-condition))
(mapcar #'sb-pcl:find-class
- '(simple-type-error simple-error
- sb-int:simple-style-warning)))))
+ '(simple-type-error
+ simple-error
+ sb-int:simple-file-error
+ sb-int:simple-style-warning)))))
;; precedence lists
(assert (equal (sb-pcl:class-precedence-list
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.37"
+"0.pre7.38"
projects / sbcl.git / commitdiff