From 416152f084604094445a758ff399871132dff2bd Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 3 Oct 2001 15:20:43 +0000 Subject: [PATCH] 0.pre7.38: (flaky5_branch RIP. There are still problems: debugging data going astray, and new DEFUN of inline FOO being too wimpy. But it seems better than 0.pre7.37. So..) merged flaky5_branch back onto the main branch --- BUGS | 94 +- NEWS | 79 +- make-target-2.sh | 16 +- package-data-list.lisp-expr | 58 +- src/code/alpha-vm.lisp | 11 +- src/code/array.lisp | 35 +- src/code/backq.lisp | 44 +- src/code/byte-interp.lisp | 14 - src/code/cold-error.lisp | 1 - src/code/cross-misc.lisp | 2 +- src/code/debug-int.lisp | 105 ++- src/code/defboot.lisp | 167 ++-- src/code/defmacro.lisp | 8 +- src/code/defstruct.lisp | 20 +- src/code/describe.lisp | 6 + src/code/early-extensions.lisp | 30 +- src/code/early-fasl.lisp | 8 +- src/code/early-setf.lisp | 11 +- src/code/eval.lisp | 81 +- src/code/filesys.lisp | 30 +- src/code/fop.lisp | 27 +- src/code/interr.lisp | 33 +- src/code/late-type.lisp | 33 +- src/code/list.lisp | 32 +- src/code/macroexpand.lisp | 2 +- src/code/macros.lisp | 1 - src/code/pathname.lisp | 2 +- src/code/seq.lisp | 20 +- src/code/show.lisp | 6 +- src/code/stream.lisp | 4 - src/code/stubs.lisp | 26 + src/code/target-alieneval.lisp | 82 +- src/code/target-misc.lisp | 3 + src/code/target-package.lisp | 31 +- src/code/target-pathname.lisp | 24 +- src/code/target-type.lisp | 3 + src/code/toplevel.lisp | 18 +- src/code/x86-vm.lisp | 26 +- src/cold/shebang.lisp | 11 +- src/compiler/array-tran.lisp | 1 - src/compiler/assem.lisp | 27 +- src/compiler/byte-comp.lisp | 23 +- src/compiler/checkgen.lisp | 4 +- src/compiler/constraint.lisp | 55 +- src/compiler/control.lisp | 68 +- src/compiler/copyprop.lisp | 12 +- src/compiler/debug-dump.lisp | 5 +- src/compiler/debug.lisp | 11 +- src/compiler/dfo.lisp | 227 ++--- src/compiler/disassem.lisp | 1578 +++++++++++++++++---------------- src/compiler/dump.lisp | 73 +- src/compiler/entry.lisp | 65 +- src/compiler/envanal.lisp | 203 +++-- src/compiler/float-tran.lisp | 2 +- src/compiler/generic/genesis.lisp | 196 ++-- src/compiler/generic/target-core.lisp | 4 +- src/compiler/gtn.lisp | 126 +-- src/compiler/ir1final.lisp | 5 +- src/compiler/ir1opt.lisp | 78 +- src/compiler/ir1tran.lisp | 233 ++--- src/compiler/ir1util.lisp | 353 ++++---- src/compiler/ir2tran.lisp | 17 +- src/compiler/knownfun.lisp | 2 +- src/compiler/lexenv.lisp | 42 +- src/compiler/life.lisp | 10 +- src/compiler/locall.lisp | 184 ++-- src/compiler/ltn.lisp | 12 +- src/compiler/macros.lisp | 10 +- src/compiler/main.lisp | 251 ++++-- src/compiler/meta-vmdef.lisp | 4 +- src/compiler/node.lisp | 344 ++++--- src/compiler/proclaim.lisp | 79 +- src/compiler/represent.lisp | 131 +-- src/compiler/srctran.lisp | 4 +- src/compiler/sset.lisp | 34 +- src/compiler/target-byte-comp.lisp | 2 +- src/compiler/target-disassem.lisp | 2 +- src/compiler/target-dump.lisp | 29 +- src/compiler/target-main.lisp | 72 +- src/compiler/tn.lisp | 9 +- src/compiler/vop.lisp | 45 +- src/pcl/defclass.lisp | 140 +-- src/pcl/defs.lisp | 27 +- src/pcl/low.lisp | 10 +- src/pcl/slots-boot.lisp | 2 +- src/pcl/std-class.lisp | 203 +++-- src/pcl/walk.lisp | 6 +- stems-and-flags.lisp-expr | 6 +- tests/array.pure.lisp | 41 + tests/clos.impure.lisp | 17 + tests/foreign.test.sh | 9 +- tests/type.impure.lisp | 22 +- version.lisp-expr | 2 +- 93 files changed, 3524 insertions(+), 2797 deletions(-) create mode 100644 src/code/stubs.lisp create mode 100644 tests/array.pure.lisp diff --git a/BUGS b/BUGS index fd5ebfc..783ffd8 100644 --- a/BUGS +++ b/BUGS @@ -389,9 +389,6 @@ WORKAROUND: 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")) @@ -1240,64 +1237,43 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 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 + (#) + 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 diff --git a/NEWS b/NEWS index 7534722..9c0bb26 100644 --- a/NEWS +++ b/NEWS @@ -815,6 +815,21 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12: 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 @@ -825,22 +840,10 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: 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 @@ -861,16 +864,50 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: :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 - . -* 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. diff --git a/make-target-2.sh b/make-target-2.sh index fb85d1d..9464a48 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -33,16 +33,24 @@ echo //doing warm init ;; 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 41c3e22..28eff37 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -144,11 +144,14 @@ "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" @@ -196,7 +199,8 @@ "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" @@ -214,11 +218,16 @@ "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" @@ -230,7 +239,8 @@ "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" @@ -342,10 +352,12 @@ "+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" @@ -724,6 +736,7 @@ retained, possibly temporariliy, because it might be used internally." ;; ..and macros.. "COLLECT" "DO-ANONYMOUS" "DOHASH" "DOVECTOR" + "NAMED-LAMBDA" "NAMED-LET" "ONCE-ONLY" "DEFENUM" @@ -842,7 +855,7 @@ retained, possibly temporariliy, because it might be used internally." "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 @@ -860,22 +873,11 @@ retained, possibly temporariliy, because it might be used internally." "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" @@ -970,7 +972,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -990,11 +991,11 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -1018,7 +1019,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -1238,7 +1238,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 03bd87f..b03bd84 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -87,12 +87,14 @@ ;;; (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. @@ -145,7 +147,6 @@ ;;; 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 - diff --git a/src/code/array.lisp b/src/code/array.lisp index e5647cd..d53b8bc 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -644,34 +644,6 @@ (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))) @@ -684,9 +656,8 @@ (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)) @@ -704,7 +675,7 @@ 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))) diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 710e402..acc7839 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -11,6 +11,8 @@ (in-package "SB!IMPL") +(/show0 "entering backq.lisp") + ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: ;;; ;;; |`,|: [a] => a @@ -45,6 +47,8 @@ (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)) @@ -57,6 +61,8 @@ (%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) @@ -74,6 +80,8 @@ (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) @@ -128,6 +136,8 @@ (values 'list* (list a (backquotify-1 dflag d))))))))))) +(/show0 "backq.lisp 139") + ;;; This handles the cases. (defun comma (code) (cond ((atom code) @@ -144,6 +154,8 @@ (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*) @@ -169,8 +181,11 @@ ;;;; 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 @@ -186,24 +201,31 @@ (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)) ;;;; 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") diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index 79160a9..563b66c 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -396,20 +396,6 @@ (defun two-arg-string< (x y) (string= x y)) (defun two-arg-string> (x y) (string= x y)) -;;;; 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))) - ;;;; funny functions ;;; (used both by the byte interpreter and by the IR1 interpreter) diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 1936675..254213c 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -116,7 +116,6 @@ ;;; 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))) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index c44584a..18f7fbb 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -73,7 +73,7 @@ (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. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 23ad564..e96f671 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -719,6 +719,7 @@ ;;; 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) @@ -738,12 +739,14 @@ ;;; 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 @@ -872,9 +875,10 @@ ;; 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 @@ -974,60 +978,70 @@ #!+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) @@ -1037,6 +1051,7 @@ (- (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)) @@ -1046,6 +1061,7 @@ ;; 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)))))))))) @@ -1743,8 +1759,8 @@ (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.. @@ -1756,13 +1772,15 @@ ;; 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))) @@ -1778,7 +1796,8 @@ (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) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 5809413..48f1497 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -141,78 +141,101 @@ (defmacro-mundanely prog2 (form1 result &body body) `(prog1 (progn ,form1 ,result) ,@body)) -;;; 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)) ;;;; DEFVAR and DEFPARAMETER @@ -313,8 +336,8 @@ ;; 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) diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index a77c741..9a79445 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -80,10 +80,10 @@ ;;; 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) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 448116b..6b1f516 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -16,7 +16,7 @@ ;;;; 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))) @@ -313,7 +313,7 @@ (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-"))) @@ -323,17 +323,25 @@ (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)))) @@ -406,7 +414,7 @@ (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)))) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index d085947..c23bb78 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -186,6 +186,8 @@ (%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)))) @@ -193,6 +195,7 @@ (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 @@ -218,6 +221,8 @@ (%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 @@ -229,6 +234,7 @@ (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. diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 79fb530..e272d48 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -589,6 +589,22 @@ ;; 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 + "~@" + name) + `(setf (fdefinition ',name) ,lambda)) ;;;; ONCE-ONLY ;;;; @@ -837,9 +853,12 @@ ;;; ;;; 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 @@ -882,7 +901,10 @@ `(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)))))) ;;;; etc. diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 64a5f68..32161b0 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -38,7 +38,7 @@ ;;; 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 @@ -66,6 +66,12 @@ ;;; 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*)) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index da77d6a..f79b473 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -61,11 +61,12 @@ ;; 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))))) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 0d71c40..bca0f12 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -17,20 +17,20 @@ (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)))) @@ -157,38 +157,31 @@ (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)))) ;;; miscellaneous full function definitions of things which are ;;; ordinarily handled magically by the compiler diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index e596852..746db69 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -529,22 +529,16 @@ (/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") @@ -768,7 +762,7 @@ ;; 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) @@ -940,7 +934,7 @@ (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 "/") diff --git a/src/code/fop.lisp b/src/code/fop.lisp index fce38fe..aabae17 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -605,12 +605,26 @@ (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 "~@") + ;; 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) @@ -645,6 +659,8 @@ (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)) @@ -660,6 +676,7 @@ (load-fresh-line) (format t "~S defined~%" res)) res)) +|# ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code ;;;; was sufficiently stale that the functions it called were no diff --git a/src/code/interr.lisp b/src/code/interr.lisp index eb4be3d..dcb2525 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -418,40 +418,55 @@ nil))))) (defun find-interrupted-name () + (/show0 "entering FIND-INTERRUPTED-NAME") (if *finding-name* (values "" 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 "" 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 "" nil)) (sb!di:debug-condition () + (/show0 "trapped DEBUG-CONDITION") (values "" nil))))) ;;;; 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)))) @@ -463,7 +478,7 @@ (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 @@ -473,7 +488,7 @@ 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))))))))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 2af355c..fc14309 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1914,16 +1914,18 @@ (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))) @@ -2187,6 +2189,15 @@ :low low :high high)))) -(!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") diff --git a/src/code/list.lisp b/src/code/list.lisp index 4f78953..55f66c9 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -16,11 +16,10 @@ ;;;; -- 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)) @@ -427,9 +426,9 @@ 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)) @@ -445,12 +444,12 @@ (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. @@ -459,10 +458,9 @@ (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) @@ -484,12 +482,12 @@ (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) @@ -930,8 +928,8 @@ (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)))))) @@ -939,8 +937,8 @@ (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)))) diff --git a/src/code/macroexpand.lisp b/src/code/macroexpand.lisp index 4806e01..8f467e5 100644 --- a/src/code/macroexpand.lisp +++ b/src/code/macroexpand.lisp @@ -50,7 +50,7 @@ ;; 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) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index fe01efd..629f7dd 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -128,7 +128,6 @@ the usual naming convention (names like *FOO*) for special variables" ;; 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. ;; diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 67b442a..c24892f 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -108,7 +108,7 @@ ;;; 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 diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 0b0e4bc..e4fdf4a 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -894,22 +894,22 @@ ,@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.")) diff --git a/src/code/show.lisp b/src/code/show.lisp index c4abb21..7ba5501 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -85,7 +85,8 @@ ;;; 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))) @@ -127,9 +128,6 @@ #+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) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index fb1d207..244425d 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -179,10 +179,6 @@ (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) diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp new file mode 100644 index 0000000..f54499f --- /dev/null +++ b/src/code/stubs.lisp @@ -0,0 +1,26 @@ +;;;; 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))) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index c935165..67daaec 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -579,23 +579,25 @@ (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. @@ -607,14 +609,15 @@ 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) @@ -628,7 +631,7 @@ (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)) @@ -643,21 +646,32 @@ (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))))))))) (defun alien-typep (object type) #!+sb-doc diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 98e818a..e5680f5 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -24,10 +24,13 @@ (%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)))))))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 24149ee..be3cbd1 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -91,21 +91,22 @@ (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))) (defvar *package* (error "*PACKAGE* should be initialized in cold load!") #!+sb-doc "the current package") diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index f1dfb0e..05497fc 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -1050,7 +1050,7 @@ a host-structure or string." ;;;; 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 @@ -1368,8 +1368,7 @@ a host-structure or string." (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)) @@ -1378,9 +1377,15 @@ a host-structure or string." (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 @@ -1398,6 +1403,13 @@ a host-structure or string." (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 diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 871cb84..a3ec9c6 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -129,8 +129,11 @@ ;;; 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)))))) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 2112163..a36683f 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -21,7 +21,7 @@ #!+sb-doc "the fixnum closest in value to negative infinity") -;;;; 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. @@ -75,15 +75,20 @@ ;;;; 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)) @@ -94,6 +99,8 @@ (%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* @@ -101,6 +108,7 @@ "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 @@ -157,8 +165,8 @@ (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 diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 73cb5eb..353e1d8 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -191,7 +191,9 @@ (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) @@ -204,16 +206,17 @@ (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. @@ -263,6 +266,7 @@ (/hexstr context) (let ((pc (context-pc context))) (declare (type system-area-pointer pc)) + (/show0 "got PC") ;; using INT3 the pc is .. INT3 code length bytes... (let* ((length (sap-ref-8 pc 1)) (vector (make-array length :element-type '(unsigned-byte 8)))) @@ -311,7 +315,7 @@ (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*) @@ -320,7 +324,7 @@ (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) @@ -333,8 +337,8 @@ ;;; 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)) diff --git a/src/cold/shebang.lisp b/src/cold/shebang.lisp index 9587efe..95b4480 100644 --- a/src/cold/shebang.lisp +++ b/src/cold/shebang.lisp @@ -11,10 +11,11 @@ (in-package "SB-COLD") -;;;; 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*) @@ -39,7 +40,7 @@ (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)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index e1fddb3..c1bc4c5 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -499,7 +499,6 @@ (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-")) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 22e90b8..290b8c5 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -27,7 +27,7 @@ ;;; 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. @@ -91,7 +91,7 @@ ;; 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 @@ -654,11 +654,11 @@ p ;; the branch has two dependents and one of them dpends on (: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 @@ -667,9 +667,9 @@ p ;; the branch has two dependents and one of them dpends on (: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 @@ -1504,9 +1504,11 @@ p ;; the branch has two dependents and one of them dpends on (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 @@ -1515,10 +1517,13 @@ p ;; the branch has two dependents and one of them dpends on (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 diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index 63e9885..528a3ff 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -141,10 +141,9 @@ (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)) @@ -1113,7 +1112,7 @@ (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))) @@ -1852,21 +1851,23 @@ (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)) ;;;; 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)) @@ -1921,6 +1922,7 @@ (values)) (defun byte-compile-component (component) + (/show "entering BYTE-COMPILE-COMPONENT") (setf (component-info component) (make-byte-component-info)) (maybe-mumble "ByteAnn ") @@ -1983,6 +1985,7 @@ (make-core-byte-component segment code-length constants xeps *compile-object*)) (null)))))) + (/show "leaving BYTE-COMPILE-COMPONENT") (values)) ;;;; extra stuff for debugging diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 3441ad6..92f4f13 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -130,7 +130,7 @@ ;;; 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.) @@ -446,7 +446,7 @@ (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. diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 328056a..c4c9755 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -187,7 +187,7 @@ ;;; 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)) @@ -217,7 +217,7 @@ (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)))) @@ -439,11 +439,11 @@ (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 @@ -457,31 +457,38 @@ (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) @@ -499,14 +506,18 @@ (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)) diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index ce58695..3a1d235 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -1,5 +1,5 @@ -;;;; 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 @@ -18,7 +18,7 @@ (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))) @@ -28,7 +28,7 @@ (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 @@ -78,23 +78,24 @@ (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) @@ -125,15 +126,17 @@ (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))) @@ -162,13 +165,14 @@ (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) @@ -198,7 +202,7 @@ (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))))) diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp index 41f886c..f7062ca 100644 --- a/src/compiler/copyprop.lisp +++ b/src/compiler/copyprop.lisp @@ -89,9 +89,9 @@ (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) @@ -118,11 +118,11 @@ (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. @@ -133,7 +133,9 @@ (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.") diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 3c954eb..043013f 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -460,7 +460,7 @@ (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 @@ -479,8 +479,7 @@ (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 diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 2458152..492d1cb 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -1074,7 +1074,8 @@ (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))) @@ -1090,8 +1091,8 @@ (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) @@ -1106,7 +1107,7 @@ (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) @@ -1116,7 +1117,7 @@ (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)) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index dd304c7..f312dff 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -37,9 +37,9 @@ (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)) @@ -82,8 +82,8 @@ (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) @@ -99,22 +99,24 @@ (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))) @@ -130,17 +132,19 @@ (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))) @@ -160,54 +164,62 @@ (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))) @@ -240,7 +252,8 @@ ((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) @@ -248,12 +261,13 @@ (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) @@ -262,8 +276,22 @@ (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) @@ -279,24 +307,25 @@ (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)) @@ -333,7 +362,7 @@ (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) @@ -350,9 +379,9 @@ (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))) @@ -360,9 +389,9 @@ (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)) @@ -392,9 +421,9 @@ (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)) @@ -404,10 +433,10 @@ (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)) @@ -415,8 +444,8 @@ (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))))) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index b58838c..d821b6b 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -77,28 +77,28 @@ 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)))) |# ;;;; cached functions @@ -122,11 +122,11 @@ #!-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) @@ -175,25 +175,25 @@ (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) @@ -214,22 +214,22 @@ (logcount x)) (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) @@ -246,19 +246,19 @@ (print-unreadable-object (inst stream :type t :identity t) (format stream "~A(~A)" (inst-name inst) (inst-format-name inst)))) -;;;; 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))) ;;;; These are the kind of values we can compute for an argument, and @@ -294,7 +294,8 @@ (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) @@ -310,21 +311,21 @@ (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)) ;;; 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 @@ -336,16 +337,16 @@ (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))) @@ -354,35 +355,36 @@ arg)) ;;;; 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 "~@" - (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) @@ -394,32 +396,32 @@ (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)) @@ -429,98 +431,109 @@ (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*) @@ -596,68 +609,69 @@ (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)) @@ -675,54 +689,54 @@ (setf (arg-use-label arg) use-label)) (when fields-p (when (null format-length) - (error - "~@" - arg-name)) + (error + "~@" + arg-name)) (setf (arg-fields arg) - (mapcar #'(lambda (bytespec) - (when (> (+ (byte-position bytespec) - (byte-size bytespec)) - format-length) - (error "~@" - 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 "~@" + 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))) @@ -737,14 +751,14 @@ (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) @@ -752,26 +766,26 @@ (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)))) (defun set-arg-from-type (arg type-name table) (let ((type-arg (find type-name table :key #'arg-name))) @@ -785,20 +799,20 @@ (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))))) (defmacro define-argument-type (name &rest args) @@ -839,115 +853,115 @@ `(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))) (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)) @@ -956,26 +970,26 @@ ;;; 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)) (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))) @@ -984,177 +998,182 @@ (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))))))))))) -(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))))) ;;;; 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)))))) (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 @@ -1168,25 +1187,25 @@ #!+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)))) ;;;; some simple functions that help avoid consing when we're just ;;;; recursively filtering things that usually don't change @@ -1206,22 +1225,22 @@ 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))))) (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)))) @@ -1230,97 +1249,97 @@ ;; 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)) @@ -1329,169 +1348,174 @@ (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))))) -(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))))))))) (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)) #!-sb-fluid (declaim (inline bytes-to-bits)) (declaim (maybe-inline sign-extend aligned-p align tab tab0)) @@ -1510,7 +1534,7 @@ (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)) @@ -1519,14 +1543,14 @@ #!+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) @@ -1541,8 +1565,8 @@ (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 diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index ba1aaa2..0a9aa0c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -544,8 +544,12 @@ (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)) @@ -1105,10 +1109,6 @@ ;;; 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)) @@ -1119,12 +1119,7 @@ (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. @@ -1205,6 +1200,9 @@ (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 @@ -1297,34 +1295,51 @@ (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)) ;;;; dumping structures diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index e0c9b8d..7025db2 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -14,10 +14,10 @@ (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) @@ -50,7 +50,7 @@ (*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)) @@ -67,41 +67,44 @@ (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)) diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp index 11b86c1..5592641 100644 --- a/src/compiler/envanal.lisp +++ b/src/compiler/envanal.lisp @@ -1,6 +1,6 @@ ;;;; 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. @@ -15,17 +15,17 @@ (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) @@ -49,6 +49,7 @@ (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) @@ -56,12 +57,13 @@ (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)) @@ -73,7 +75,37 @@ (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)) @@ -81,14 +113,24 @@ (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 @@ -108,17 +150,17 @@ (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)) @@ -140,10 +182,10 @@ (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)) @@ -156,22 +198,22 @@ ;;;; 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)) @@ -198,19 +240,22 @@ (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)) @@ -238,10 +283,11 @@ (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)) @@ -256,18 +302,19 @@ ;;;; 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) @@ -303,11 +350,11 @@ (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) @@ -326,10 +373,10 @@ (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)) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 3d82e9f..9ad9f7e 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -269,7 +269,7 @@ ;;; 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)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ce9e73f..d156696 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -139,14 +139,16 @@ (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) @@ -1024,8 +1026,8 @@ ;; (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) @@ -1293,41 +1295,69 @@ (cold-push (string-to-core (package-name pkg)) res) res)) -;;;; 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) @@ -1343,10 +1373,13 @@ (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))) @@ -1799,8 +1832,8 @@ ;;;; 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) @@ -1830,8 +1863,8 @@ (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)))) ;;;; cold fops for loading lists @@ -2194,10 +2227,22 @@ ;;;; 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))) @@ -2205,7 +2250,10 @@ (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. @@ -2641,13 +2689,14 @@ (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 @@ -2662,33 +2711,30 @@ cross-compiler knew their inline definition and used that everywhere that they were called before the out-of-line definition is installed, as is fairly common for structure accessors.) initially undefined function references:~2%") - (labels ((key (name) - (etypecase name - (symbol (symbol-name name)) - ;; FIXME: should use standard SETF-function parsing logic - (list (key (second name)))))) - (dolist (name (sort undefs #'string< :key #'key)) - (format t "~S" name) - ;; FIXME: This ACCESSOR-FOR stuff should go away when the - ;; code has stabilized. (It's only here to help me - ;; categorize the flood of undefined functions caused by - ;; completely rewriting the bootstrap process. Hopefully any - ;; future maintainers will mostly have small numbers of - ;; undefined functions..) - (let ((accessor-for (info :function :accessor-for name))) - (when accessor-for - (format t " (accessor for ~S)" accessor-for))) - (format t "~%"))))) - - (format t "~%~|~%layout names:~2%") - (collect ((stuff)) - (maphash #'(lambda (name gorp) - (declare (ignore name)) - (stuff (cons (descriptor-bits (car gorp)) - (cdr gorp)))) - *cold-layouts*) - (dolist (x (sort (stuff) #'< :key #'car)) - (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x))) + + (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)) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index b0e698f..da4ac3c 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -106,6 +106,8 @@ (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) @@ -166,4 +168,4 @@ (setf (code-header-ref code-obj code-obj-index) xep)))))))))) (values)) - +|# \ No newline at end of file diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index e2520f8..e508d22 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -30,11 +30,12 @@ (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)) @@ -54,38 +55,42 @@ (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))) @@ -96,13 +101,14 @@ (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))) @@ -120,11 +126,11 @@ (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)) @@ -151,18 +157,18 @@ (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 @@ -172,10 +178,11 @@ :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)) @@ -190,10 +197,11 @@ (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))) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index c843505..d6cf88c 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -52,7 +52,7 @@ )))))) ;;; 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) @@ -60,8 +60,7 @@ (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*)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f1654c6..8768bdb 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -166,10 +166,10 @@ (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))) @@ -184,7 +184,7 @@ (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) @@ -216,9 +216,9 @@ ;;;; 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 @@ -310,10 +310,10 @@ ;;; 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. ;;; @@ -604,14 +604,16 @@ ;;; 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 @@ -762,23 +764,25 @@ ;;; 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))) @@ -913,8 +917,8 @@ ;;;; 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) @@ -1105,7 +1109,7 @@ ;;;; 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.) @@ -1174,7 +1178,7 @@ ;;; 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) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index f8bb594..45f95c6 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -18,7 +18,7 @@ ;;; 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*) @@ -40,7 +40,7 @@ ;;; *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, @@ -325,11 +325,11 @@ ;;; 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 @@ -364,7 +364,8 @@ ;;; *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*) @@ -500,7 +501,7 @@ (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. @@ -1326,6 +1327,9 @@ (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 @@ -1646,24 +1650,24 @@ 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 @@ -1671,9 +1675,9 @@ ;;; 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. @@ -1741,9 +1745,9 @@ 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 @@ -1853,8 +1857,8 @@ ;;;; 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) @@ -1882,9 +1886,9 @@ (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 @@ -2777,12 +2781,14 @@ ;;; 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)) @@ -2869,11 +2875,11 @@ ;;; 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 @@ -2889,55 +2895,6 @@ :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. @@ -2967,8 +2924,7 @@ ;;; 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)) @@ -3027,54 +2983,55 @@ (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)) + +;;;; 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)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index da56197..2832443 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -14,9 +14,9 @@ ;;;; 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) @@ -254,7 +254,7 @@ (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)))) @@ -262,31 +262,31 @@ (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) @@ -299,7 +299,7 @@ (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)) @@ -357,10 +357,10 @@ (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))) @@ -380,11 +380,11 @@ (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) @@ -413,9 +413,8 @@ (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))) @@ -424,9 +423,8 @@ (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)) @@ -439,8 +437,8 @@ (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)) @@ -451,7 +449,7 @@ (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 () @@ -466,8 +464,8 @@ (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)) @@ -506,15 +504,16 @@ ;;;; 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)) @@ -536,9 +535,9 @@ (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))) @@ -554,8 +553,8 @@ (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)) @@ -565,26 +564,28 @@ (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)) @@ -621,23 +622,24 @@ (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))) @@ -668,9 +670,9 @@ (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)) @@ -702,17 +704,17 @@ (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)) @@ -731,8 +733,8 @@ (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) @@ -742,15 +744,16 @@ (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))) @@ -815,10 +818,10 @@ (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. @@ -859,8 +862,8 @@ (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))) @@ -868,8 +871,8 @@ (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)) @@ -886,10 +889,11 @@ (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) @@ -910,22 +914,24 @@ (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) @@ -951,19 +957,21 @@ (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)) @@ -1025,8 +1033,8 @@ (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))) @@ -1036,9 +1044,9 @@ (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))) @@ -1116,14 +1124,14 @@ (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)) @@ -1132,9 +1140,9 @@ (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)) @@ -1149,8 +1157,8 @@ :type (ctype-of object) :where-from :defined))) -;;; 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))) @@ -1161,8 +1169,6 @@ ;;;; 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 @@ -1170,10 +1176,10 @@ (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) @@ -1191,15 +1197,14 @@ (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))) @@ -1214,13 +1219,14 @@ 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))) @@ -1236,10 +1242,10 @@ (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 @@ -1247,6 +1253,17 @@ (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~% ~ @@ -1301,21 +1318,21 @@ (: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 @@ -1439,7 +1456,7 @@ (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)))) @@ -1497,8 +1514,8 @@ (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*))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 2c53ed4..ea17576 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -60,6 +60,18 @@ (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 @@ -146,6 +158,7 @@ ;;; 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)) @@ -1060,7 +1073,9 @@ (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))) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 3b38e95..fefd236 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -125,7 +125,7 @@ ;; 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)) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 299eda9..37b9ca6 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -17,16 +17,15 @@ ;;; (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 . ) (a local macro, with the specifier - ;; expander.) Note that NAME may be a (SETF ) 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 . ) (a + ;; local macro, with the specifier expander). Note that NAME may be + ;; a (SETF ) 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 @@ -47,7 +46,7 @@ ;; "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 @@ -56,12 +55,35 @@ ;; 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)))) diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index cd04213..05cdbdf 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -394,9 +394,9 @@ (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 @@ -416,8 +416,8 @@ (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)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 093ddd0..a347996 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -21,13 +21,14 @@ (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. @@ -46,17 +47,19 @@ (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)))) @@ -95,10 +98,10 @@ ;;;; 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 @@ -106,7 +109,7 @@ ;;; 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. @@ -118,7 +121,7 @@ ;;; 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) @@ -192,12 +195,12 @@ (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))) @@ -206,7 +209,7 @@ (change-ref-leaf ref (or (functional-entry-function fun) (make-external-entry-point fun)))))) -;;; 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 @@ -217,7 +220,7 @@ ;;; 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) @@ -241,16 +244,16 @@ (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 @@ -278,7 +281,25 @@ (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. @@ -307,23 +328,24 @@ 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)) @@ -649,25 +671,67 @@ 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)) @@ -689,6 +753,7 @@ (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 @@ -782,14 +847,15 @@ ;;; 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)) @@ -813,7 +879,7 @@ ;;; 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) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 1ce7180..ea9c1dd 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -300,9 +300,9 @@ ;;; 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 @@ -316,7 +316,7 @@ ;;; 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)) @@ -965,7 +965,7 @@ ;;; 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 @@ -977,6 +977,10 @@ (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) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 8591b38..5844829 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -594,7 +594,7 @@ (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)) @@ -629,12 +629,12 @@ ,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 diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 84a9aa8..6ac6bc2 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -30,13 +30,17 @@ *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 @@ -44,13 +48,18 @@ ;;; 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) @@ -374,6 +383,7 @@ (values)) (defun native-compile-component (component) + (/show "entering NATIVE-COMPILE-COMPONENT") (let ((*code-segment* nil) (*elsewhere* nil)) (maybe-mumble "GTN ") @@ -465,12 +475,17 @@ ;; 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 @@ -479,21 +494,23 @@ ;;; 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 @@ -504,11 +521,15 @@ (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) @@ -791,7 +812,6 @@ (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) @@ -855,21 +875,6 @@ (*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. @@ -892,6 +897,131 @@ (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. @@ -924,17 +1054,16 @@ (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 @@ -1078,7 +1207,7 @@ (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 @@ -1087,7 +1216,7 @@ (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)))) @@ -1182,25 +1311,16 @@ (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) @@ -1232,8 +1352,7 @@ (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)) @@ -1251,12 +1370,7 @@ ;;; 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)) @@ -1370,7 +1484,8 @@ ;; 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 @@ -1380,14 +1495,6 @@ 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 diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 0e2975b..2d73241 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -1607,9 +1607,9 @@ ;;; ;;; :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*)}* diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index a3c62d9..41d2953 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -29,7 +29,7 @@ (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 @@ -272,8 +272,20 @@ (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) @@ -285,7 +297,7 @@ ;; 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. @@ -294,8 +306,8 @@ (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)) @@ -308,131 +320,198 @@ (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 "" :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. @@ -443,18 +522,18 @@ ;;; 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)) @@ -489,7 +568,7 @@ (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) @@ -534,7 +613,7 @@ (def!struct (constant (:include leaf)) ;; the value of the constant (value nil :type t)) -(defprinter (constant) +(defprinter (constant :identity t) (name :test name) value) @@ -551,7 +630,7 @@ ;; 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))) @@ -567,7 +646,7 @@ (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) @@ -589,7 +668,7 @@ ;; 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)) @@ -626,11 +705,11 @@ ;; 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. @@ -657,19 +736,27 @@ ;; :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)) @@ -687,7 +774,7 @@ (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, @@ -698,54 +785,61 @@ (: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))) @@ -763,11 +857,11 @@ ;;; 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 @@ -793,18 +887,18 @@ ;; 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))) @@ -839,7 +933,7 @@ ;; 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) @@ -880,7 +974,7 @@ ;; 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))) @@ -898,7 +992,7 @@ (: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. @@ -915,7 +1009,7 @@ ;; 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) @@ -930,7 +1024,7 @@ (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))) @@ -967,7 +1061,7 @@ (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 @@ -1014,7 +1108,7 @@ ;; 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) @@ -1032,7 +1126,7 @@ (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 @@ -1050,7 +1144,7 @@ ;; 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)) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 4c86f5f..3bedcb5 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -125,53 +125,42 @@ (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 - "~@" - 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))) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index ab4403e..3f049b3 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -26,8 +26,8 @@ ;;; 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))) @@ -75,8 +75,8 @@ (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)) @@ -85,8 +85,8 @@ (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)) @@ -182,8 +182,8 @@ ;;;; 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 () @@ -303,10 +303,10 @@ (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)) @@ -328,8 +328,9 @@ (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)) @@ -342,9 +343,9 @@ (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))) @@ -380,15 +381,16 @@ (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) @@ -414,25 +416,27 @@ :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)) @@ -476,10 +480,11 @@ (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) @@ -501,12 +506,12 @@ (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)) @@ -567,10 +572,11 @@ 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) @@ -603,9 +609,9 @@ (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)) @@ -618,14 +624,15 @@ (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))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 8631e17..0fd8c48 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2874,7 +2874,7 @@ ;;; 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)) @@ -3271,7 +3271,7 @@ (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 diff --git a/src/compiler/sset.lisp b/src/compiler/sset.lisp index 2b1b290..9106839 100644 --- a/src/compiler/sset.lisp +++ b/src/compiler/sset.lisp @@ -15,16 +15,20 @@ (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))) @@ -33,7 +37,7 @@ (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) @@ -51,7 +55,7 @@ (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) @@ -63,7 +67,7 @@ (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)) @@ -77,12 +81,11 @@ ;;; 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) @@ -102,7 +105,8 @@ (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)))))))) @@ -147,8 +151,8 @@ (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) diff --git a/src/compiler/target-byte-comp.lisp b/src/compiler/target-byte-comp.lisp index 8b8d977..65f9f3c 100644 --- a/src/compiler/target-byte-comp.lisp +++ b/src/compiler/target-byte-comp.lisp @@ -13,7 +13,7 @@ (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 diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 7a854dc..1fb8c87 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1542,7 +1542,7 @@ (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) diff --git a/src/compiler/target-dump.lisp b/src/compiler/target-dump.lisp index 0c9d4d3..f18255a 100644 --- a/src/compiler/target-dump.lisp +++ b/src/compiler/target-dump.lisp @@ -101,35 +101,11 @@ (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)))) ;;;; 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. @@ -145,3 +121,4 @@ (dump-fop 'fop-make-byte-compiled-function file) (dump-byte nslots file)) (values)) +|# \ No newline at end of file diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 673c998..2b53bd4 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -15,23 +15,24 @@ ;;;; 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 @@ -47,14 +48,21 @@ (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) @@ -70,7 +78,6 @@ (*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 @@ -82,24 +89,9 @@ (*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 diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 042d247..b5d39cc 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -297,10 +297,11 @@ ;;;; 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)) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index a1fe842..39c688a 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -328,25 +328,28 @@ ;; 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. @@ -355,8 +358,8 @@ (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 @@ -626,13 +629,13 @@ (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 @@ -837,10 +840,10 @@ ;; ;; :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 @@ -855,11 +858,11 @@ ;; 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 @@ -900,7 +903,7 @@ (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. diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 1309b5d..a608ddc 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -46,12 +46,12 @@ ;;; 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)) @@ -59,66 +59,69 @@ 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 @@ -135,9 +138,16 @@ ;; 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*)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index f65650e..2d9bcf0 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -53,17 +53,16 @@ (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)) @@ -406,22 +405,22 @@ (/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))) @@ -449,10 +448,10 @@ ;; 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)) @@ -472,7 +471,7 @@ 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*") ;;;; the classes that define the kernel of the metabraid diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 383d113..dbe1094 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -167,12 +167,20 @@ (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 diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index a73b7b7..865fc94 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -88,7 +88,7 @@ (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) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 0c90dc3..37fde27 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -352,6 +352,16 @@ (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)) @@ -366,25 +376,16 @@ *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)))) (defmethod shared-initialize :after @@ -477,6 +478,61 @@ (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 @@ -512,88 +568,39 @@ 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)) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index c8e0eb8..6f51770 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -134,12 +134,12 @@ ;; 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) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index daedc35..5992a75 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -257,6 +257,8 @@ ("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) @@ -414,7 +416,7 @@ ("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") @@ -574,10 +576,12 @@ ;; 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) diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp new file mode 100644 index 0000000..d25d97c --- /dev/null +++ b/tests/array.pure.lisp @@ -0,0 +1,41 @@ +;;;; 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 diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 983fd57..90b5120 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -48,6 +48,23 @@ (format t "~&No applicable method for ZUT-N-A-M ~S, yet.~%" args)) (zut-n-a-m 1 2 3) + +;; 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) diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh index 3fa04e8..0afbf39 100644 --- a/tests/foreign.test.sh +++ b/tests/foreign.test.sh @@ -20,10 +20,11 @@ make $testfilestem.o ld -shared -o $testfilestem.so $testfilestem.o ${SBCL:-sbcl} <