From: William Harold Newman Date: Wed, 6 Jun 2001 21:43:50 +0000 (+0000) Subject: 0.6.12.22: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git 0.6.12.22: DB logical pathname and COMPILE-FILE-PATHNAME patch from sbcl-devel 2001-06-01 made FASL file version number independent of CPU type; also made byte FASL file version number the same many many changes more or less related to changing the FASL file version number.. ..created SB!FASL package to hold stuff like +FASL-FILE-VERSION+ which is common to loading and dumping ..renamed early-load.lisp to early-fasl.lisp ..renamed FASL-FILE stuff to FASL-OUTPUT ..*LAP-OUTPUT-FILE* doesn't need to be special (and so is renamed to LAP-FASL-OUTPUT). ..exported FAST-READ stuff from SB-INT, so that it's visible in SB-FASL ..deleted old stale load-related variables *LOAD-BYTE-COMPILED-CODE-TO-DYNAMIC-SPACE* *LOAD-X86-TLF-TO-DYNAMIC-SPACE* *ENABLE-DYNAMIC-SPACE-CODE* (hardwiring code which referred to them to use their effectively-constant values T, NIL, T instead). (Now we no longer need to worry about what package they're in..) ..made some symbols external to SB-KERNEL so that now-in-SB-FASL code could find them (and so that some of the old :: prefixes could go away): *FREE-INTERRUPT-CONTEXT-INDEX*, *!INITIAL-FOO* for all FOO, *CURRENT-CATCH-BLOCK*, *CURRENT-UNWIND-PROTECT-BLOCK*, *PSEUDO-ATOMIC-ATOMIC*, *PSEUDO-ATOMIC-INTERRUPTED* ..deleted unneeded "SB!IMPL::" prefixes for various other *STATIC-SYMBOLS*-related symbols which're exported (mostly from SB-KERNEL) already ..deleted unused %INITIAL-FUNCTION (smashing Alpha *STATIC-SYMBOLS* indices) suppressed some stuff in side-effectful-pathnames.test.sh until we merge the DB cleanups from flaky2_branch --- diff --git a/BUGS b/BUGS index 10de5c0..efc6e60 100644 --- a/BUGS +++ b/BUGS @@ -956,6 +956,20 @@ Error in function C::GET-LAMBDA-TO-COMPILE: non-compound forms (like the bare symbol COUNT, in his example) here. +104: + (DESCRIBE 'SB-ALIEN:DEF-ALIEN-TYPE) reports the macro argument list + incorrectly: + DEF-ALIEN-TYPE is + an external symbol + in #. + Macro-function: # + Macro arguments: (#:whole-470 #:environment-471) + On Sat, May 26, 2001 09:45:57 AM CDT it was compiled from: + /usr/stuff/sbcl/src/code/host-alieneval.lisp + Created: Monday, March 12, 2001 07:47:43 AM CST + +105: + (DESCRIBE 'STREAM-READ-BYTE) KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/NEWS b/NEWS index 5032fb2..9ab2a07 100644 --- a/NEWS +++ b/NEWS @@ -741,6 +741,8 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12: patch, so that DISASSEMBLE output is much nicer. * better error handling in CLOS method combination, thanks to Martin Atzmueller and Pierre Mai +* Logical pathnames work better, thanks to various fixes and + tests from Dan Barlow. * Hash tables can be printed readably, as inspired by CMU CL code of Eric Marsden and SBCL code of Martin Atzmueller. * a new slam.sh hack to shorten the edit/compile/debug cycle for @@ -756,6 +758,11 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12: COMPILE-FILE is no longer supported, so that now every function gets an entry point, so that block compilation looks a little more like the plain vanilla ANSI section 3.2.2.3 scheme. +* Fasl file version numbers are now independent of the target CPU, + since historically most system changes which required version + number changes have affected all CPUs equally. Similarly, + the byte fasl file version is now equal to the ordinary + fasl file version. planned incompatible changes in 0.7.x: * The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc. diff --git a/make-host-2.sh b/make-host-2.sh index 8b0979a..dd6751e 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -50,7 +50,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (load "src/cold/defun-load-or-cload-xcompiler.lisp") (load-or-cload-xcompiler #'host-load-stem) (defun proclaim-target-optimization () - (let ((debug (if (find :sb-show *shebang-features*) 2 1))) + (let ((debug (if (position :sb-show *shebang-features*) 2 1))) (sb-xc:proclaim `(optimize (compilation-speed 1) (debug ,debug) (sb!ext:inhibit-warnings 2) @@ -96,14 +96,14 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 ;; Let's check that the type system was reasonably sane. (It's ;; easy to spend a long time wandering around confused trying ;; to debug cold init if it wasn't.) - (when (find :sb-test *shebang-features*) + (when (position :sb-test *shebang-features*) (load "tests/type.after-xc.lisp")) ;; If you're experimenting with the system under a ;; cross-compilation host which supports CMU-CL-style SAVE-LISP, ;; this can be a good time to run it. The resulting core isn't ;; used in the normal build, but can be handy for experimenting ;; with the system. (See slam.sh for an example.) - (when (find :sb-after-xc-core *shebang-features*) + (when (position :sb-after-xc-core *shebang-features*) #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil) #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core") ) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1fc9049..6760f3d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -77,7 +77,7 @@ #s(sb-cold:package-data :name "SB!ASSEM" :doc "private: the assembler, used by the compiler" - :use ("CL" "SB!INT" "SB!EXT") + :use ("CL" "SB!EXT" "SB!INT") :export ("ASSEMBLY-UNIT" "*ASSEM-SCHEDULER-P*" @@ -142,17 +142,15 @@ ;; package for this? But it seems like a fairly low priority.) ;; (Probably the same considerations also explain why BIGNUM is ;;in the USE list.) - :use ("CL" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!BIGNUM" - #!+sb-dyncount "SB-DYNCOUNT" - "SB!EXT" "SB!INT" "SB!KERNEL" "SB!ASSEM" "SB!SYS") + :use ("CL" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!ASSEM" "SB!BIGNUM" + #!+sb-dyncount "SB-DYNCOUNT" "SB!EXT" "SB!FASL" "SB!INT" + "SB!KERNEL" "SB!SYS") :reexport ("SLOT" "CODE-INSTRUCTIONS" "FLUSHABLE") :export ("%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" "*BACKEND-BYTE-ORDER*" "*BACKEND-DISASSEM-PARAMS*" - "*BACKEND-FASL-FILE-IMPLEMENTATION*" - "*BACKEND-FASL-FILE-TYPE*" "*BACKEND-FASL-FILE-VERSION*" "*BACKEND-INFO-ENVIRONMENT*" "*BACKEND-INSTRUCTION-FLAVORS*" "*BACKEND-INSTRUCTION-FORMATS*" "*BACKEND-INTERNAL-ERRORS*" "*BACKEND-PAGE-SIZE*" @@ -165,8 +163,6 @@ "*CODE-SEGMENT*" "*CONVERTING-FOR-INTERPRETER*" "*COUNT-VOP-USAGES*" "*ELSEWHERE*" - "*FASL-HEADER-STRING-START-STRING*" - "*FASL-HEADER-STRING-STOP-CHAR-CODE*" "*SETF-ASSUMED-FBOUNDP*" "*SUPPRESS-VALUES-DECLARATION*" @@ -184,7 +180,8 @@ "CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32" "CLOSURE-INIT" "CLOSURE-REF" "CODE-CONSTANT-REF" "CODE-CONSTANT-SET" - "COMPILE-FOR-EVAL" "COMPONENT" "COMPONENT-HEADER-LENGTH" + "COMPILE-FOR-EVAL" "COMPILER-ERROR" + "COMPONENT" "COMPONENT-HEADER-LENGTH" "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUNCTION" "COMPUTE-OLD-NFP" "COPY-MORE-ARG" "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" @@ -259,11 +256,9 @@ "NOTE-NEXT-INSTRUCTION" "SET-SLOT" "LOCATION-NUMBER" - "BYTE-FASL-FILE-VERSION" "*COMPONENT-BEING-COMPILED*" "BLOCK-NUMBER" "BACKEND" - "BACKEND-BYTE-FASL-FILE-IMPLEMENTATION" "IR2-BLOCK-BLOCK" "DISASSEM-BYTE-COMPONENT" "FUNCALLABLE-INSTANCE-LEXENV" @@ -318,13 +313,38 @@ "IR2-COMPONENT-DYNCOUNT-INFO" "DYNCOUNT-INFO" "DYNCOUNT-INFO-P")) + #s(sb-cold:package-data + :name "SB!FASL" + :doc "private: stuff related to FASL load/dump logic (and GENESIS)" + :use ("CL" "SB!ALIEN" "SB!ASSEM" "SB!BIGNUM" "SB!C" "SB!C-CALL" + "SB!EXT" "SB!INT" "SB!KERNEL" "SB!SYS") + :export ("*ASSEMBLER-ROUTINES*" + "+BACKEND-FASL-FILE-IMPLEMENTATION+" + "*BACKEND-FASL-FILE-TYPE*" + "CLOSE-FASL-OUTPUT" + "DUMP-ASSEMBLER-ROUTINES" + "DUMP-OBJECT" + "FASL-CONSTANT-ALREADY-DUMPED-P" + "+FASL-FILE-VERSION+" + "FASL-DUMP-BYTE-COMPONENT" + "FASL-DUMP-COLD-LOAD-FORM" "FASL-DUMP-COMPONENT" + "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-VALIDATE-STRUCTURE" + "*!LOAD-TIME-VALUES*" + "LOAD-TYPE-PREDICATE" + "OPEN-FASL-OUTPUT" + "*!REVERSED-COLD-TOPLEVELS*" + "*STATIC-FOREIGN-SYMBOLS*")) + ;; This package is a grab bag for things which used to be internal ;; symbols in package COMMON-LISP. Lots of these symbols are accessed ;; with explicit SB!IMPL:: prefixes in the code. It would be nice to ;; reduce the use of this practice, so if symbols from here which are ;; accessed that way are found to belong more appropriately in - ;; an existing package (e.g. KERNEL or SYS or EXT) or a new package - ;; (e.g. something to collect together all the FOP stuff), I + ;; an existing package (e.g. KERNEL or SYS or EXT or FASL), I ;; (WHN 19990223) encourage maintainers to move them there.. ;; ;; ..except that it's getting so big and crowded that maybe it @@ -333,7 +353,7 @@ :name "SB!IMPL" :doc "private: a grab bag of implementation details" :use ("CL" "SB!ALIEN" "SB!BIGNUM" "SB!C-CALL" "SB!DEBUG" "SB!EXT" - "SB!GRAY" "SB!INT" "SB!KERNEL" "SB!SYS")) + "SB!FASL" "SB!GRAY" "SB!INT" "SB!KERNEL" "SB!SYS")) #s(sb-cold:package-data :name "SB!DEBUG" @@ -588,14 +608,14 @@ like *STACK-TOP-HINT*" #s(sb-cold:package-data :name "SB!FORMAT" :doc "private: implementation of FORMAT and friends" - :use ("CL" "SB!KERNEL" "SB!EXT" "SB!INT")) + :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")) #s(sb-cold:package-data :name "SB!GRAY" :doc "public: an implementation of the stream-definition-by-user Lisp extension proposal by David N. Gray" - :use ("CL" "SB!KERNEL" "SB!EXT" "SB!INT") + :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL") :export ("FUNDAMENTAL-BINARY-STREAM" "FUNDAMENTAL-BINARY-INPUT-STREAM" "FUNDAMENTAL-BINARY-OUTPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM" "FUNDAMENTAL-CHARACTER-INPUT-STREAM" @@ -616,7 +636,7 @@ Lisp extension proposal by David N. Gray" "private: miscellaneous unsupported extensions to the ANSI spec. Most of the stuff in here originated in CMU CL's EXTENSIONS package and is retained, possibly temporariliy, because it might be used internally." - :use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!SYS" "SB!GRAY") + :use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!GRAY" "SB!FASL" "SB!SYS") :export ("*AFTER-SAVE-INITIALIZATIONS*" "*BEFORE-SAVE-INITIALIZATIONS*" "*ALL-MODIFIER-NAMES*" @@ -668,7 +688,7 @@ retained, possibly temporariliy, because it might be used internally." ;; miscellaneous non-standard but handy user-level functions.. "ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ" "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" - "SANE-PACKAGE" + "SANE-PACKAGE" "SANE-DEFAULT-PATHNAME-DEFAULTS" "CIRCULAR-LIST-P" "SWAPPED-ARGS-FUN" "ANY/TYPE" "EVERY/TYPE" @@ -807,6 +827,21 @@ retained, possibly temporariliy, because it might be used internally." ;; a sort of quasi unbound tag for use in hash tables "+EMPTY-HT-SLOT+" + ;; low-level i/o stuff + "DONE-WITH-FAST-READ-BYTE" + "DONE-WITH-FAST-READ-CHAR" + "FAST-READ-BYTE" + "FAST-READ-BYTE-REFILL" + "FAST-READ-CHAR" + "FAST-READ-CHAR-REFILL" + "FAST-READ-S-INTEGER" + "FAST-READ-U-INTEGER" + "FAST-READ-VARIABLE-U-INTEGER" + "FILE-NAME" + "INTERN*" + "PREPARE-FOR-FAST-READ-BYTE" + "PREPARE-FOR-FAST-READ-CHAR" + ;; not used any more, I think -- WHN 19991206 #+nil ("SERVE-BUTTON-PRESS" @@ -842,7 +877,7 @@ retained, possibly temporariliy, because it might be used internally." integration' (said CMU CL architecture.tex) and that probably was and is a good idea, but see SB-SYS for blurring of boundaries." :use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!BIGNUM" - "SB!EXT" "SB!INT" "SB!SYS" "SB!GRAY") + "SB!EXT" "SB!FASL" "SB!INT" "SB!SYS" "SB!GRAY") :import-from (("SB!C-CALL" "VOID")) :reexport ("DEF!STRUCT" "DEF!MACRO" "VOID" "WEAK-POINTER-P") :export ("%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" @@ -955,11 +990,12 @@ is a good idea, but see SB-SYS for blurring of boundaries." "DOUBLE-FLOAT-P" "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS" - "ERROR-NUMBER-OR-LOSE" "FDOCUMENTATION" "FILENAME" + "ERROR-NUMBER-OR-LOSE" "FDEFINITION-OBJECT" + "FDOCUMENTATION" "FILENAME" "FIND-AND-INIT-OR-CHECK-LAYOUT" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" "FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION" - "FORM" "FUNCALLABLE-INSTANCE-P" + "FORM" "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P" "FUNCTION-CODE-HEADER" "FUNCTION-DOC" "FUNCTION-TYPE" "FUNCTION-TYPE-ALLOWP" @@ -976,7 +1012,11 @@ is a good idea, but see SB-SYS for blurring of boundaries." "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER" "HANDLE-CIRCULARITY" "IGNORE-IT" "ILL-BIN" "ILL-BOUT" "ILL-IN" "ILL-OUT" - "INDEX-TOO-LARGE-ERROR" "INTEGER-DECODE-DOUBLE-FLOAT" + "INDEX-TOO-LARGE-ERROR" + "*!INITIAL-ASSEMBLER-ROUTINES*" + "*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*" + "*!INITIAL-LAYOUTS*" "*!INITIAL-SYMBOLS*" + "INTEGER-DECODE-DOUBLE-FLOAT" "INTEGER-DECODE-LONG-FLOAT" "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-ERROR" "INTERNAL-TIME" "INTERSECTION-TYPE" "INTERSECTION-TYPE-P" @@ -1078,14 +1118,16 @@ is a good idea, but see SB-SYS for blurring of boundaries." "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS" "PARSE-DEFMACRO" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE" - "PARSE-UNKNOWN-TYPE-SPECIFIER" - "PATHNAME-DESIGNATOR" "PUNT-PRINT-IF-TOO-LONG" + "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR" + #+x86 "*PSEUDO-ATOMIC-ATOMIC*" + #+x86 "*PSEUDO-ATOMIC-INTERRUPTED*" + "PUNT-PRINT-IF-TOO-LONG" "READER-PACKAGE-ERROR" #!+gengc "*SAVED-STATE-CHAIN*" "SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT" "SCALE-SINGLE-FLOAT" "SEQUENCE-END" "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE" - "SET-HEADER-DATA" "SHIFT-TOWARDS-END" + "SET-ARRAY-HEADER" "SET-HEADER-DATA" "SHIFT-TOWARDS-END" "SHIFT-TOWARDS-START" "SHRINK-VECTOR" "SIGNED-BYTE-32-P" "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-P" @@ -1237,9 +1279,6 @@ is a good idea, but see SB-SYS for blurring of boundaries." "!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT" "!CLASS-FINALIZE" "GC-COLD-INIT-OR-REINIT" - ;; These belong in an "SB!LOAD" package someday. - "*STATIC-FOREIGN-SYMBOLS*" "*ASSEMBLER-ROUTINES*" - ;; Note: These are out of lexicographical order because in CMU CL ;; they were defined as internal symbols in package "CL" ;; imported into package "C", as opposed to what we're @@ -1542,7 +1581,7 @@ no guarantees of interface stability." "EPROTONOSUPPORT" "UNIX-SIGBLOCK" "SIGIO" "ENOMEM" "SIGEMT" "EFAULT" "ENODEV" "EIO" "EVICEERR" "ETXTBSY" "EWOULDBLOCK" "EAGAIN" "EDESTADDRREQ" "ENOEXEC" "ENETUNREACH" "ENOTEMPTY" - "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY" "ENFILE" + "ENFILE" "SIGTTOU" "EEXIST" "SIGPROF" "SIGSTOP" "ENETRESET" "SIGURG" "ENOBUFS" "EPROCLIM" "EROFS" "ETOOMANYREFS" "UNIX-FILE-KIND" "ELOCAL" "UNIX-SIGSETMASK" "EREMOTE" "ESOCKTNOSUPPORT" @@ -1601,8 +1640,9 @@ no guarantees of interface stability." :doc "internal: the default place to hide information about the hardware and data structure representations" - :use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!ASSEM" - "SB!C" "SB!C-CALL" "SB!EXT" "SB!INT" "SB!KERNEL" "SB!SYS" "SB!UNIX") + :use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!ASSEM" "SB!C" + "SB!C-CALL" "SB!EXT" "SB!FASL" "SB!INT" "SB!KERNEL" + "SB!SYS" "SB!UNIX") :export ("*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*" "AFTER-BREAKPOINT-TRAP" "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" @@ -1754,7 +1794,6 @@ structure representations" #!-gencgc "DYNAMIC-1-SPACE-END" "READ-ONLY-SPACE-START" "READ-ONLY-SPACE-END" "TARGET-BYTE-ORDER" - "TARGET-FASL-CODE-FORMAT" "TARGET-FASL-FILE-TYPE" "TARGET-HEAP-ADDRESS-SPACE" "*TARGET-MOST-NEGATIVE-FIXNUM*" "*TARGET-MOST-POSITIVE-FIXNUM*" "STATIC-SPACE-START" "STATIC-SPACE-END" diff --git a/src/assembly/alpha/assem-rtns.lisp b/src/assembly/alpha/assem-rtns.lisp index 06aa556..c005c0f 100644 --- a/src/assembly/alpha/assem-rtns.lisp +++ b/src/assembly/alpha/assem-rtns.lisp @@ -40,32 +40,32 @@ ;; assume that we are never called with nvals == 1 and that a0 has already ;; been loaded. (inst ble nvals default-a0-and-on) - (inst ldl a1 (* 1 sb!vm:word-bytes) vals) + (inst ldl a1 (* 1 word-bytes) vals) (inst subq nvals (fixnumize 2) count) (inst ble count default-a2-and-on) - (inst ldl a2 (* 2 sb!vm:word-bytes) vals) + (inst ldl a2 (* 2 word-bytes) vals) (inst subq nvals (fixnumize 3) count) (inst ble count default-a3-and-on) - (inst ldl a3 (* 3 sb!vm:word-bytes) vals) + (inst ldl a3 (* 3 word-bytes) vals) (inst subq nvals (fixnumize 4) count) (inst ble count default-a4-and-on) - (inst ldl a4 (* 4 sb!vm:word-bytes) vals) + (inst ldl a4 (* 4 word-bytes) vals) (inst subq nvals (fixnumize 5) count) (inst ble count default-a5-and-on) - (inst ldl a5 (* 5 sb!vm:word-bytes) vals) + (inst ldl a5 (* 5 word-bytes) vals) (inst subq nvals (fixnumize 6) count) (inst ble count done) ;; Copy the remaining args to the top of the stack. - (inst addq vals (* 6 sb!vm:word-bytes) vals) - (inst addq cfp-tn (* 6 sb!vm:word-bytes) dst) + (inst addq vals (* 6 word-bytes) vals) + (inst addq cfp-tn (* 6 word-bytes) dst) LOOP (inst ldl temp 0 vals) - (inst addq vals sb!vm:word-bytes vals) + (inst addq vals word-bytes vals) (inst stl temp 0 dst) (inst subq count (fixnumize 1) count) - (inst addq dst sb!vm:word-bytes dst) + (inst addq dst word-bytes dst) (inst bne count loop) (inst br zero-tn done) @@ -128,32 +128,32 @@ ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) - (inst ldl a0 (* 0 sb!vm:word-bytes) args) - (inst ldl a1 (* 1 sb!vm:word-bytes) args) - (inst ldl a2 (* 2 sb!vm:word-bytes) args) - (inst ldl a3 (* 3 sb!vm:word-bytes) args) - (inst ldl a4 (* 4 sb!vm:word-bytes) args) - (inst ldl a5 (* 5 sb!vm:word-bytes) args) + (inst ldl a0 (* 0 word-bytes) args) + (inst ldl a1 (* 1 word-bytes) args) + (inst ldl a2 (* 2 word-bytes) args) + (inst ldl a3 (* 3 word-bytes) args) + (inst ldl a4 (* 4 word-bytes) args) + (inst ldl a5 (* 5 word-bytes) args) ;; Calc SRC, DST, and COUNT (inst subq nargs (fixnumize register-arg-count) count) - (inst addq args (* sb!vm:word-bytes register-arg-count) src) + (inst addq args (* word-bytes register-arg-count) src) (inst ble count done) - (inst addq cfp-tn (* sb!vm:word-bytes register-arg-count) dst) + (inst addq cfp-tn (* word-bytes register-arg-count) dst) LOOP ;; Copy one arg. (inst ldl temp 0 src) - (inst addq src sb!vm:word-bytes src) + (inst addq src word-bytes src) (inst stl temp 0 dst) (inst subq count (fixnumize 1) count) - (inst addq dst sb!vm:word-bytes dst) + (inst addq dst word-bytes dst) (inst bgt count loop) DONE ;; We are done. Do the jump. (progn - (loadw temp lexenv sb!vm:closure-function-slot sb!vm:function-pointer-type) + (loadw temp lexenv closure-function-slot function-pointer-type) (lisp-jump temp lip))) @@ -174,11 +174,11 @@ (:temp temp1 non-descriptor-reg nl3-offset)) (declare (ignore start count)) - (load-symbol-value cur-uwp sb!impl::*current-unwind-protect-block*) + (load-symbol-value cur-uwp *current-unwind-protect-block*) (let ((error (generate-error-code nil invalid-unwind-error))) (inst beq block error)) - (loadw target-uwp block sb!vm:unwind-block-current-uwp-slot) + (loadw target-uwp block unwind-block-current-uwp-slot) (inst cmpeq cur-uwp target-uwp temp1) (inst beq temp1 do-uwp) @@ -186,16 +186,16 @@ do-exit - (loadw cfp-tn cur-uwp sb!vm:unwind-block-current-cont-slot) - (loadw code-tn cur-uwp sb!vm:unwind-block-current-code-slot) + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) (progn - (loadw lra cur-uwp sb!vm:unwind-block-entry-pc-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) (lisp-return lra lip :frob-code nil)) do-uwp - (loadw next-uwp cur-uwp sb!vm:unwind-block-current-uwp-slot) - (store-symbol-value next-uwp sb!impl::*current-unwind-protect-block*) + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (store-symbol-value next-uwp *current-unwind-protect-block*) (inst br zero-tn do-exit)) (define-assembly-routine @@ -209,17 +209,17 @@ (progn start count) ; We just need them in the registers. - (load-symbol-value catch sb!impl::*current-catch-block*) + (load-symbol-value catch *current-catch-block*) loop (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst beq catch error)) - (loadw tag catch sb!vm:catch-block-tag-slot) + (loadw tag catch catch-block-tag-slot) (inst cmpeq tag target temp1) (inst bne temp1 exit) - (loadw catch catch sb!vm:catch-block-previous-catch-slot) + (loadw catch catch catch-block-previous-catch-slot) (inst br zero-tn loop) exit diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index d2dc911..7de12e5 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -12,24 +12,20 @@ (in-package "SB!C") -(defvar *do-assembly* nil - #!+sb-doc "If non-NIL, emit assembly code. If NIL, emit VOP templates.") +;;; If non-NIL, emit assembly code. If NIL, emit VOP templates. +(defvar *do-assembly* nil) -(defvar *lap-output-file* nil - #!+sb-doc "the FASL file currently being output to") +;;; a list of (NAME . LABEL) for every entry point +(defvar *entry-points* nil) -(defvar *entry-points* nil - #!+sb-doc "a list of (name . label) for every entry point") +;;; Set this to NIL to inhibit assembly-level optimization. (For +;;; compiler debugging, rather than policy control.) +(defvar *assembly-optimize* t) -(defvar *assembly-optimize* t - #!+sb-doc - "Set this to NIL to inhibit assembly-level optimization. For compiler - debugging, rather than policy control.") - -;;; Note: You might think from the name that this would act like COMPILE-FILE, -;;; but in fact it's arguably more like LOAD, even down to the return -;;; convention. It LOADs a file, then writes out any assembly code created -;;; by the process. +;;; Note: You might think from the name that this would act like +;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down +;;; to the return convention. It LOADs a file, then writes out any +;;; assembly code created by the process. (defun assemble-file (name &key (output-file (make-pathname :defaults name @@ -37,7 +33,8 @@ ;; FIXME: Consider nuking the filename defaulting logic here. (let* ((*do-assembly* t) (name (pathname name)) - (*lap-output-file* (open-fasl-file (pathname output-file) name)) + ;; the fasl file currently being output to + (lap-fasl-output (open-fasl-output (pathname output-file) name)) (*entry-points* nil) (won nil) (*code-segment* nil) @@ -50,7 +47,7 @@ (load (merge-pathnames name (make-pathname :type "lisp"))) (fasl-dump-cold-load-form `(in-package ,(package-name (sane-package))) - *lap-output-file*) + lap-fasl-output) (sb!assem:append-segment *code-segment* *elsewhere*) (setf *elsewhere* nil) (let ((length (sb!assem:finalize-segment *code-segment*))) @@ -58,9 +55,9 @@ length *fixups* *entry-points* - *lap-output-file*)) + lap-fasl-output)) (setq won t)) - (close-fasl-file *lap-output-file* (not won))) + (close-fasl-output lap-fasl-output (not won))) won)) (defstruct (reg-spec (:copier nil)) diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp index 3784517..c56dbdc 100644 --- a/src/assembly/x86/assem-rtns.lisp +++ b/src/assembly/x86/assem-rtns.lisp @@ -195,7 +195,7 @@ (declare (ignore start count)) - (load-symbol-value catch sb!impl::*current-catch-block*) + (load-symbol-value catch *current-catch-block*) LOOP @@ -230,7 +230,7 @@ (inst or block block) ; check for NULL pointer (inst jmp :z error)) - (load-symbol-value uwp sb!impl::*current-unwind-protect-block*) + (load-symbol-value uwp *current-unwind-protect-block*) ;; Does *cuwpb* match value stored in argument cuwp slot? (inst cmp uwp @@ -238,13 +238,13 @@ ;; If a match, return to context in arg block. (inst jmp :e do-exit) - ;; Not a match - return to *current-unwind-protect-block* context. + ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context. ;; Important! Must save (and return) the arg 'block' for later use!! (move edx-tn block) (move block uwp) ;; Set next unwind protect context. (loadw uwp uwp unwind-block-current-uwp-slot) - (store-symbol-value uwp sb!impl::*current-unwind-protect-block*) + (store-symbol-value uwp *current-unwind-protect-block*) DO-EXIT diff --git a/src/code/array.lisp b/src/code/array.lisp index 1edce29..9b6e9fb 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -831,10 +831,9 @@ (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S" fill-pointer)))) +;;; Destructively alter VECTOR, changing its length to NEW-LENGTH, +;;; which must be less than or equal to its current length. (defun shrink-vector (vector new-length) - #!+sb-doc - "Destructively alter VECTOR, changing its length to NEW-LENGTH, which - must be less than or equal to its current length." (declare (vector vector)) (unless (array-header-p vector) (macrolet ((frob (name &rest things) @@ -874,10 +873,9 @@ (setf (%array-fill-pointer vector) new-length) vector) +;;; Fill in array header with the provided information, and return the array. (defun set-array-header (array data length fill-pointer displacement dimensions &optional displacedp) - #!+sb-doc - "Fills in array header with provided information. Returns array." (setf (%array-data-vector array) data) (setf (%array-available-elements array) length) (cond (fill-pointer diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index a890b0a..cb73c3c 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -232,7 +232,7 @@ (value (cdr x))) (setf (svref res value) (if (and (consp key) (eq (car key) '%fdefinition-marker%)) - (sb!impl::fdefinition-object (cdr key) t) + (fdefinition-object (cdr key) t) key)))) res)) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 956797f..e5bce7a 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -311,7 +311,7 @@ instead (which is another name for the same thing).")) ;; reason.. (Perhaps we should do it anyway in case someone ;; manages to save an image from within a pseudo-atomic-atomic ;; operation?) - #!+x86 (setf sb!impl::*pseudo-atomic-atomic* 0)) + #!+x86 (setf *pseudo-atomic-atomic* 0)) (gc-on))) ;;;; some support for any hapless wretches who end up debugging cold diff --git a/src/code/cross-io.lisp b/src/code/cross-io.lisp index 2714eaf..5932205 100644 --- a/src/code/cross-io.lisp +++ b/src/code/cross-io.lisp @@ -9,7 +9,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!IMPL") +(in-package "SB!FASL") ;;;; fast-read operations ;;;; diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 04e2f30..83378bd 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1109,7 +1109,7 @@ #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil)) + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (sb!alien:with-alien ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) @@ -1145,7 +1145,7 @@ #!-x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil)) + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (sb!alien:with-alien ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) (let ((scp (sb!alien:deref lisp-interrupt-contexts index))) @@ -1292,7 +1292,7 @@ code-locations at which execution would continue with frame as the top frame if someone threw to the corresponding tag." (let ((catch - #!-gengc (descriptor-sap sb!impl::*current-catch-block*) + #!-gengc (descriptor-sap *current-catch-block*) #!+gengc (mutator-current-catch-block)) (res nil) (fp (frame-pointer (frame-real-frame frame)))) diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp index c3bcaee..ec6b02b 100644 --- a/src/code/early-impl.lisp +++ b/src/code/early-impl.lisp @@ -11,6 +11,10 @@ ;;; entries in STATIC-SYMBOLS table, references to which can be compiled ;;; as though they're special variables +;;; +;;; FIXME: These should be listed once and only once, instead of +;;; listed here and then listed separately (and by now, 2001-06-06, +;;; slightly differently) elsewhere. (declaim (special *posix-argv* *!initial-fdefn-objects* *read-only-space-free-pointer* @@ -18,10 +22,15 @@ sb!vm:*initial-dynamic-space-free-pointer* *current-catch-block* *current-unwind-protect-block* - sb!c::*eval-stack-top* + *eval-stack-top* sb!vm::*alien-stack* - ;; KLUDGE: I happened to notice that these should be #!+X86. - ;; There could easily be others in the list, too. + ;; FIXME: The pseudo-atomic variable stuff should be + ;; conditional on :SB-PSEUDO-ATOMIC-SYMBOLS, which + ;; should be conditional on :X86, instead of the + ;; pseudo-atomic stuff being directly conditional on + ;; :X86. (Note that non-X86 ports mention + ;; pseudo-atomicity too, but they handle it without + ;; messing with special variables.) #!+x86 *pseudo-atomic-atomic* #!+x86 *pseudo-atomic-interrupted* sb!unix::*interrupts-enabled* diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 583345f..6df3f9f 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1272,6 +1272,8 @@ ;;; This is kind of like FILE-POSITION, but is an internal hack used ;;; by the filesys stuff to get and set the file name. +;;; +;;; FIXME: misleading name, screwy interface (defun file-name (stream &optional new-name) (when (typep stream 'fd-stream) (cond (new-name diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 586c970..58dce2a 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -787,11 +787,12 @@ (error 'simple-file-error :pathname pathname :format-control "can't use a wild pathname here")) - (let ((namestring (unix-namestring pathname t))) + (let* ((defaulted-pathname (merge-pathnames + pathname + (sane-default-pathname-defaults))) + (namestring (unix-namestring defaulted-pathname t))) (when (and namestring (sb!unix:unix-file-kind namestring)) - (let ((truename (sb!unix:unix-resolve-links - (sb!unix:unix-maybe-prepend-current-directory - namestring)))) + (let ((truename (sb!unix:unix-resolve-links namestring))) (when truename (let ((*ignore-wildcards* t)) (pathname (sb!unix:unix-simplify-pathname truename)))))))) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index f78317b..fce38fe 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -1,6 +1,6 @@ ;;;; FOP definitions -(in-package "SB!IMPL") +(in-package "SB!FASL") ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP ;;; describes what the body does to the fop stack: @@ -192,7 +192,7 @@ (n-size (gensym)) (n-buffer (gensym))) `(define-fop (,name ,code) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let ((,n-package ,package) (,n-size (fast-read-u-integer ,name-size))) (when (> ,n-size *load-symbol-buffer-size*) @@ -201,7 +201,7 @@ (* ,n-size 2))))) (done-with-fast-read-byte) (let ((,n-buffer *load-symbol-buffer*)) - (read-string-as-bytes *fasl-file* + (read-string-as-bytes *fasl-input-stream* ,n-buffer ,n-size) (push-fop-table (intern* ,n-buffer @@ -249,7 +249,7 @@ (fop-uninterned-small-symbol-save 13) (let* ((arg (clone-arg)) (res (make-string arg))) - (read-string-as-bytes *fasl-file* res) + (read-string-as-bytes *fasl-input-stream* res) (push-fop-table (make-symbol res)))) (define-fop (fop-package 14) @@ -257,12 +257,12 @@ ;;;; fops for loading numbers -;;; Load a signed integer LENGTH bytes long from *FASL-FILE*. +;;; Load a signed integer LENGTH bytes long from *FASL-INPUT-STREAM*. (defun load-s-integer (length) (declare (fixnum length)) ;; #+cmu (declare (optimize (inhibit-warnings 2))) (do* ((index length (1- index)) - (byte 0 (read-byte *fasl-file*)) + (byte 0 (read-byte *fasl-input-stream*)) (result 0 (+ result (ash byte bits))) (bits 0 (+ bits 8))) ((= index 0) @@ -275,13 +275,13 @@ (load-s-integer (clone-arg))) (define-fop (fop-word-integer 35) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (fast-read-s-integer 4) (done-with-fast-read-byte)))) (define-fop (fop-byte-integer 36) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (fast-read-s-integer 1) (done-with-fast-read-byte)))) @@ -295,14 +295,14 @@ (%make-complex (pop-stack) im))) (define-fop (fop-complex-single-float 72) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (complex (make-single-float (fast-read-s-integer 4)) (make-single-float (fast-read-s-integer 4))) (done-with-fast-read-byte)))) (define-fop (fop-complex-double-float 73) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (let* ((re-lo (fast-read-u-integer 4)) (re-hi (fast-read-u-integer 4)) @@ -315,7 +315,7 @@ #!+long-float (define-fop (fop-complex-long-float 67) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (let* ((re-lo (fast-read-u-integer 4)) #!+sparc (re-mid (fast-read-u-integer 4)) @@ -331,12 +331,12 @@ (done-with-fast-read-byte)))) (define-fop (fop-single-float 46) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (make-single-float (fast-read-s-integer 4)) (done-with-fast-read-byte)))) (define-fop (fop-double-float 47) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (let ((lo (fast-read-u-integer 4))) (make-double-float (fast-read-s-integer 4) lo)) @@ -344,7 +344,7 @@ #!+long-float (define-fop (fop-long-float 52) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (let ((lo (fast-read-u-integer 4)) #!+sparc (mid (fast-read-u-integer 4)) @@ -394,7 +394,7 @@ (define-cloned-fops (fop-string 37) (fop-small-string 38) (let* ((arg (clone-arg)) (res (make-string arg))) - (read-string-as-bytes *fasl-file* res) + (read-string-as-bytes *fasl-input-stream* res) res)) (define-cloned-fops (fop-vector 39) (fop-small-vector 40) @@ -424,20 +424,20 @@ (define-fop (fop-single-float-vector 84) (let* ((length (read-arg 4)) (result (make-array length :element-type 'single-float))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes)) result)) (define-fop (fop-double-float-vector 85) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-float))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2)) result)) #!+long-float (define-fop (fop-long-float-vector 88) (let* ((length (read-arg 4)) (result (make-array length :element-type 'long-float))) - (read-n-bytes *fasl-file* + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4)) @@ -446,20 +446,20 @@ (define-fop (fop-complex-single-float-vector 86) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex single-float)))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2)) result)) (define-fop (fop-complex-double-float-vector 87) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-float)))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2 2)) result)) #!+long-float (define-fop (fop-complex-long-float-vector 89) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex long-float)))) - (read-n-bytes *fasl-file* result 0 + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2)) result)) @@ -468,7 +468,7 @@ ;;; This must be packed according to the local byte-ordering, allowing us to ;;; directly read the bits. (define-fop (fop-int-vector 43) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size @@ -482,7 +482,7 @@ size))))) (declare (type index len)) (done-with-fast-read-byte) - (read-n-bytes *fasl-file* + (read-n-bytes *fasl-input-stream* res 0 (ceiling (the index (* size len)) @@ -492,7 +492,7 @@ ;;; This is the same as FOP-INT-VECTOR, except this is for signed ;;; SIMPLE-ARRAYs. (define-fop (fop-signed-int-vector 50) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size @@ -504,7 +504,7 @@ size))))) (declare (type index len)) (done-with-fast-read-byte) - (read-n-bytes *fasl-file* + (read-n-bytes *fasl-input-stream* res 0 (ceiling (the index (* (if (= size 30) @@ -661,9 +661,9 @@ (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 longer defined, -;;;; so I (William Harold Newman) deleted it. +;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code +;;;; was sufficiently stale that the functions it called were no +;;;; longer defined, so I (William Harold Newman) deleted it. ;;;; ;;;; In case someone in the future is trying to make sense of FOP layout, ;;;; it might be worth recording that the Dylan FOPs were @@ -680,7 +680,7 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-n-bytes *fasl-file* sym 0 len) + (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object (read-arg 4) (foreign-symbol-address-as-integer sym) diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp index 42fe943..1654689 100644 --- a/src/code/kernel.lisp +++ b/src/code/kernel.lisp @@ -11,117 +11,98 @@ (in-package "SB!KERNEL") +;;; Return the 24 bits of data in the header of object X, which must +;;; be an other-pointer object. (defun get-header-data (x) - #!+sb-doc - "Return the 24 bits of data in the header of object X, which must be an - other-pointer object." (get-header-data x)) +;;; Set the 24 bits of data in the header of object X (which must be +;;; an other-pointer object) to VAL. (defun set-header-data (x val) - #!+sb-doc - "Sets the 24 bits of data in the header of object X (which must be an - other-pointer object) to VAL." (set-header-data x val)) +;;; Return the length of the closure X. This is one more than the +;;; number of variables closed over. (defun get-closure-length (x) - #!+sb-doc - "Returns the length of the closure X. This is one more than the number - of variables closed over." (get-closure-length x)) +;;; Return the three-bit lowtag for the object X. (defun get-lowtag (x) - #!+sb-doc - "Returns the three-bit lowtag for the object X." (get-lowtag x)) +;;; Return the 8-bit header type for the object X. (defun get-type (x) - #!+sb-doc - "Returns the 8-bit header type for the object X." (get-type x)) +;;; Return a System-Area-Pointer pointing to the data for the vector +;;; X, which must be simple. +;;; +;;; FIXME: so it should be SIMPLE-VECTOR-SAP, right? (defun vector-sap (x) - #!+sb-doc - "Return a System-Area-Pointer pointing to the data for the vector X, which - must be simple." (declare (type (simple-unboxed-array (*)) x)) (vector-sap x)) +;;; Return a System-Area-Pointer pointing to the end of the binding stack. (defun sb!c::binding-stack-pointer-sap () - #!+sb-doc - "Return a System-Area-Pointer pointing to the end of the binding stack." (sb!c::binding-stack-pointer-sap)) +;;; Return a System-Area-Pointer pointing to the next free word of the +;;; current dynamic space. (defun sb!c::dynamic-space-free-pointer () - #!+sb-doc - "Returns a System-Area-Pointer pointing to the next free work of the current - dynamic space." (sb!c::dynamic-space-free-pointer)) +;;; Return a System-Area-Pointer pointing to the end of the control stack. (defun sb!c::control-stack-pointer-sap () - #!+sb-doc - "Return a System-Area-Pointer pointing to the end of the control stack." (sb!c::control-stack-pointer-sap)) +;;; Return the header typecode for FUNCTION. Can be set with SETF. (defun function-subtype (function) - #!+sb-doc - "Return the header typecode for FUNCTION. Can be set with SETF." (function-subtype function)) - (defun (setf function-subtype) (type function) (setf (function-subtype function) type)) +;;; Extract the arglist from the function header FUNC. (defun %function-arglist (func) - #!+sb-doc - "Extracts the arglist from the function header FUNC." (%function-arglist func)) +;;; Extract the name from the function header FUNC. (defun %function-name (func) - #!+sb-doc - "Extracts the name from the function header FUNC." (%function-name func)) +;;; Extract the type from the function header FUNC. (defun %function-type (func) - #!+sb-doc - "Extracts the type from the function header FUNC." (%function-type func)) +;;; Extract the function from CLOSURE. (defun %closure-function (closure) - #!+sb-doc - "Extracts the function from CLOSURE." (%closure-function closure)) +;;; Return the length of VECTOR. There is no reason to use this in +;;; ordinary code, 'cause length (the vector foo)) is the same. (defun sb!c::vector-length (vector) - #!+sb-doc - "Return the length of VECTOR. There is no reason to use this, 'cause - (length (the vector foo)) is the same." (sb!c::vector-length vector)) +;;; Extract the INDEXth slot from CLOSURE. (defun %closure-index-ref (closure index) - #!+sb-doc - "Extract the INDEXth slot from CLOSURE." (%closure-index-ref closure index)) +;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and +;;; WORDS words long. Note: it is your responsibility to ensure that the +;;; relation between LENGTH and WORDS is correct. (defun allocate-vector (type length words) - #!+sb-doc - "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and - WORDS words long. Note: it is your responsibility to ensure that the - relation between LENGTH and WORDS is correct." (allocate-vector type length words)) +;;; Allocate an array header with type code TYPE and rank RANK. (defun make-array-header (type rank) - #!+sb-doc - "Allocate an array header with type code TYPE and rank RANK." (make-array-header type rank)) +;;; Return a SAP pointing to the instructions part of CODE-OBJ. (defun code-instructions (code-obj) - #!+sb-doc - "Return a SAP pointing to the instructions part of CODE-OBJ." (code-instructions code-obj)) +;;; Extract the INDEXth element from the header of CODE-OBJ. Can be +;;; set with SETF. (defun code-header-ref (code-obj index) - #!+sb-doc - "Extract the INDEXth element from the header of CODE-OBJ. Can be set with - setf." (code-header-ref code-obj index)) (defun code-header-set (code-obj index new) diff --git a/src/code/load.lisp b/src/code/load.lisp index 3e98990..de45d75 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -14,59 +14,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!IMPL") - -;;;; variables - -;;; FIXME: It's awkward having LOAD stuff in SB!IMPL and dump stuff in -;;; SB!C. Among other things, it makes it hard to figure out where -;;; *FASL-HEADER-STRING-START-STRING* and -;;; *FASL-HEADER-STRING-STOP-CHAR-CODE* should go. Perhaps we should -;;; make a package called SB-DUMP or SB-LD which includes all -;;; knowledge of both loading and dumping. - -;;; This value is used to identify fasl files. Even though this is not -;;; declared as a constant (because ANSI Common Lisp has no facility -;;; for declaring values which are constant under EQUAL but not EQL), -;;; obviously you shouldn't mess with it lightly. If you do set a new -;;; value for some reason, keep these things in mind: -;;; * To avoid confusion with the similar but incompatible CMU CL -;;; fasl file format, the value should not be "FASL FILE", which -;;; is what CMU CL used for the same purpose. -;;; * Since its presence at the head of a file is used by LOAD to -;;; decide whether a file is to be fasloaded or just loaded -;;; ordinarily (as source), the value should be something which -;;; can't legally appear at the head of a Lisp source file. -;;; * The value should not contain any line-terminating characters, -;;; because they're hard to express portably and because the LOAD -;;; code might reasonably use READ-LINE to get the value to compare -;;; against. -(defparameter sb!c:*fasl-header-string-start-string* "# FASL" - #!+sb-doc - "a string which appears at the start of a fasl file header") - -(defparameter sb!c:*fasl-header-string-stop-char-code* 255 - #!+sb-doc - "the code for a character which terminates a fasl file header") - -(defvar *load-depth* 0 - #!+sb-doc - "the current number of recursive loads") -(declaim (type index *load-depth*)) - -;;; the FASL file we're reading from -(defvar *fasl-file*) -(declaim (type lisp-stream *fasl-file*)) - -(defvar *load-print* nil - #!+sb-doc - "the default for the :PRINT argument to LOAD") -(defvar *load-verbose* nil - ;; Note that CMU CL's default for this was T, and ANSI says it's - ;; implementation-dependent. We choose NIL on the theory that it's - ;; a nicer default behavior for Unix programs. - #!+sb-doc - "the default for the :VERBOSE argument to LOAD") +(in-package "SB!FASL") ;;;; miscellaneous load utilities @@ -134,12 +82,12 @@ (cnt 1 (1+ cnt))) ((>= cnt n) res)))) -;;; Read an N-byte unsigned integer from the *FASL-FILE* +;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM* (defmacro read-arg (n) (declare (optimize (speed 0))) (if (= n 1) - `(the (unsigned-byte 8) (read-byte *fasl-file*)) - `(prepare-for-fast-read-byte *fasl-file* + `(the (unsigned-byte 8) (read-byte *fasl-input-stream*)) + `(prepare-for-fast-read-byte *fasl-input-stream* (prog1 (fast-read-u-integer ,n) (done-with-fast-read-byte))))) @@ -270,13 +218,13 @@ (when byte ;; Read the string part of the fasl header, or die. - (let* ((fhsss sb!c:*fasl-header-string-start-string*) + (let* ((fhsss *fasl-header-string-start-string*) (fhsss-length (length fhsss))) (unless (= byte (char-code (schar fhsss 0))) (error "illegal first byte in fasl file header")) (do ((byte (read-byte stream) (read-byte stream)) (count 1 (1+ count))) - ((= byte sb!c:*fasl-header-string-stop-char-code*) + ((= byte +fasl-header-string-stop-char-code+) t) (declare (fixnum byte count)) (when (and (< count fhsss-length) @@ -305,15 +253,15 @@ needed-version)) t))) (or (check-version "native code" - #.sb!c:*backend-fasl-file-implementation* - #.sb!c:*backend-fasl-file-version*) + +backend-fasl-file-implementation+ + +fasl-file-version+) (check-version "byte code" - #.(sb!c:backend-byte-fasl-file-implementation) - sb!c:byte-fasl-file-version) + (backend-byte-fasl-file-implementation) + +fasl-file-version+) (error "~S was compiled for implementation ~A, but this is a ~A." stream implementation - sb!c:*backend-fasl-file-implementation*))))))) + +backend-fasl-file-implementation+))))))) ;; Setting this variable gives you a trace of fops as they are loaded and ;; executed. @@ -390,7 +338,7 @@ (error "attempt to load an empty FASL file:~% ~S" (namestring stream))) (do-load-verbose stream verbose) - (let* ((*fasl-file* stream) + (let* ((*fasl-input-stream* stream) (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) (*current-fop-table-size* (length *current-fop-table*)) (*fop-stack-pointer-on-entry* *fop-stack-pointer*)) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 7e8e78d..b3127f3 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -179,6 +179,25 @@ (type-of maybe-package)) '*package* really-package))))))) +;;; Access *DEFAULT-PATHNAME-DEFAULTS*, warning if it's silly. (Unlike +;;; the vaguely-analogous SANE-PACKAGE, we don't actually need to +;;; reset the variable when it's silly, since even crazy values of +;;; *DEFAULT-PATHNAME-DEFAULTS* don't leave the system in a state where +;;; it's hard to recover interactively.) +(defun sane-default-pathname-defaults () + (let* ((dfd *default-pathname-defaults*) + (dfd-dir (pathname-directory dfd))) + ;; It's generally not good to use a relative pathname for + ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames + ;; are defined by merging into a default pathname (which is, + ;; by default, *DEFAULT-PATHNAME-DEFAULTS*). + (when (and (consp dfd-dir) + (eql (first dfd-dir) :relative)) + (warn + "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>" + '*default-pathname-defaults*)) + *default-pathname-defaults*)) + ;;; Give names to elements of a numeric sequence. (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) &rest identifiers) diff --git a/src/code/save.lisp b/src/code/save.lisp index dfaa5cf..cd6e61d 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -105,27 +105,3 @@ (without-gcing (save (unix-namestring core-file-name nil) (get-lisp-obj-address #'restart-lisp))))) - -;;;; functions used by worldload.lisp in CMU CL bootstrapping - -;;; If NAME has been byte-compiled, and :RUNTIME is a feature, then -;;; load the byte-compiled version, otherwise just do normal load. -#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814 -(defun maybe-byte-load (name &optional (load-native t)) - (let ((bname (make-pathname - :defaults name - :type #.(sb!c:backend-byte-fasl-file-type)))) - (cond ((and (featurep :runtime) - (probe-file bname)) - (load bname)) - (load-native - (load name))))) - -;;; Replace a cold-loaded native object file with a byte-compiled one, if it -;;; exists. -#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814 -(defun byte-load-over (name) - (load (make-pathname - :defaults name - :type #.(sb!c:backend-byte-fasl-file-type)) - :if-does-not-exist nil)) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index bb82e38..b47f4c4 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -11,21 +11,19 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!IMPL") +(in-package "SB!FASL") (defvar *load-source-default-type* "lisp" #!+sb-doc "The source file types which LOAD looks for by default.") +(declaim (type (or pathname null) *load-truename* *load-pathname*)) (defvar *load-truename* nil #!+sb-doc "the TRUENAME of the file that LOAD is currently loading") - (defvar *load-pathname* nil #!+sb-doc "the defaulted pathname that LOAD is currently loading") - -(declaim (type (or pathname null) *load-truename* *load-pathname*)) ;;;; LOAD-AS-SOURCE @@ -73,17 +71,16 @@ (t (let ((first-line (with-open-file (stream truename :direction :input) (read-line stream nil))) - (fhs sb!c:*fasl-header-string-start-string*)) + (fhsss *fasl-header-string-start-string*)) (cond ((and first-line (>= (length (the simple-string first-line)) - (length fhs)) - (string= first-line fhs :end1 (length fhs))) + (length fhsss)) + (string= first-line fhsss :end1 (length fhsss))) (internal-load pathname truename if-does-not-exist verbose print :binary)) (t - (when (string= (pathname-type truename) - sb!c:*backend-fasl-file-type*) + (when (string= (pathname-type truename) *backend-fasl-file-type*) (error "File has a fasl file type, but no fasl file header:~% ~S" (namestring truename))) (internal-load pathname truename if-does-not-exist verbose print @@ -109,7 +106,7 @@ (multiple-value-bind (src-pn src-tn) (try-default-type pathname *load-source-default-type*) (multiple-value-bind (obj-pn obj-tn) - (try-default-type pathname sb!c:*backend-fasl-file-type*) + (try-default-type pathname *backend-fasl-file-type*) (cond ((and obj-tn src-tn @@ -237,13 +234,24 @@ (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop-stack))) (sb!sys:without-gcing - (read-n-bytes *fasl-file* + (read-n-bytes *fasl-input-stream* (code-instructions code) 0 #!-gengc code-length #!+gengc (* code-length sb!vm:word-bytes))) code))) +;;; Moving native code during a GC or purify is not so trivial on the +;;; x86 port. +;;; +;;; Our strategy for allowing the loading of x86 native code into the +;;; dynamic heap requires that the addresses of fixups be saved for +;;; all these code objects. After a purify these fixups can be +;;; dropped. In CMU CL, this policy was enabled with +;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used. +;;; +;;; A little analysis of the header information is used to determine +;;; if a code object is byte compiled, or native code. #!+x86 (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) @@ -254,17 +262,12 @@ (push (pop-stack) stuff)) (let* ((dbi (car (last stuff))) ; debug-info (tto (first stuff)) ; trace-table-offset - (load-to-dynamic-space - (or *enable-dynamic-space-code* - ;; definitely byte-compiled code? - (and *load-byte-compiled-code-to-dynamic-space* - (sb!c::debug-info-p dbi) - (not (sb!c::compiled-debug-info-p dbi))) - ;; or a x86 top level form? - (and *load-x86-tlf-to-dynamic-space* - (sb!c::compiled-debug-info-p dbi) - (string= (sb!c::compiled-debug-info-name dbi) - "top-level form")))) ) + ;; Old CMU CL code had maybe-we-shouldn't-load-to-dyn-space + ;; pussyfooting around here, apparently dating back to the + ;; stone age of the X86 port, but in SBCL we always load + ;; to dynamic space. FIXME: So now this "variable" could go + ;; away entirely. + (load-to-dynamic-space t)) (setq stuff (nreverse stuff)) @@ -309,7 +312,10 @@ (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop stuff))) (sb!sys:without-gcing - (read-n-bytes *fasl-file* (code-instructions code) 0 code-length)) + (read-n-bytes *fasl-input-stream* + (code-instructions code) + 0 + code-length)) code))))) ;;;; linkage fixups diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index cca3068..a63916f 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -1418,12 +1418,10 @@ a host-structure or string." :namestring namestr :offset (cdadr chunks))))) (parse-host (logical-chunkify namestr start end))) - (values host :unspecific - (and (not (equal (directory)'(:absolute))) - (directory)) - name type version)))) + (values host :unspecific (directory) name type version)))) -;;; We can't initialize this yet because not all host methods are loaded yet. +;;; We can't initialize this yet because not all host methods are +;;; loaded yet. (defvar *logical-pathname-defaults*) (defun logical-pathname (pathspec) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 02504a2..410f1a6 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -15,14 +15,16 @@ (defconstant most-positive-fixnum #.sb!vm:*target-most-positive-fixnum* #!+sb-doc - "The fixnum closest in value to positive infinity.") + "the fixnum closest in value to positive infinity") (defconstant most-negative-fixnum #.sb!vm:*target-most-negative-fixnum* #!+sb-doc - "The fixnum closest in value to negative infinity.") + "the fixnum closest in value to negative infinity") ;;;; magic specials initialized by genesis +;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..)) +;;; of all static symbols in early-impl.lisp. #!-gengc (progn (defvar *current-catch-block*) diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 9c1e08c..b907676 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -60,30 +60,30 @@ (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (flet ((add-fixup (code offset) - ;; Although this could check for and ignore fixups for code - ;; objects in the read-only and static spaces, this should - ;; only be the case when *enable-dynamic-space-code* is - ;; True. - (when sb!impl::*enable-dynamic-space-code* - (incf *num-fixups*) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) - (let ((new-fixups - (adjust-array fixups (1+ (length fixups)) - :element-type '(unsigned-byte 32)))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (get-type fixups) - sb!vm:unbound-marker-type) - (zerop fixups)) - (format t "** Init. code FU = ~S~%" fixups)) ; FIXME + ;; (We check for and ignore fixups for code objects in the + ;; read-only and static spaces. (In the old CMU CL code + ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, + ;; but in SBCL relocatable dynamic space code is always in + ;; use, so we always do the check.) + (incf *num-fixups*) + (let ((fixups (code-header-ref code code-constants-offset))) + (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) + (let ((new-fixups + (adjust-array fixups (1+ (length fixups)) + :element-type '(unsigned-byte 32)))) + (setf (aref new-fixups (length fixups)) offset) (setf (code-header-ref code code-constants-offset) - (make-specializable-array - 1 - :element-type '(unsigned-byte 32) - :initial-element offset)))))))) + new-fixups))) + (t + (unless (or (eq (get-type fixups) + sb!vm:unbound-marker-type) + (zerop fixups)) + (format t "** Init. code FU = ~S~%" fixups)) ; FIXME + (setf (code-header-ref code code-constants-offset) + (make-specializable-array + 1 + :element-type '(unsigned-byte 32) + :initial-element offset))))))) (sb!sys:without-gcing (let* ((sap (truly-the system-area-pointer (sb!kernel:code-instructions code))) diff --git a/src/compiler/alpha/backend-parms.lisp b/src/compiler/alpha/backend-parms.lisp index 195dcc2..9149984 100644 --- a/src/compiler/alpha/backend-parms.lisp +++ b/src/compiler/alpha/backend-parms.lisp @@ -18,10 +18,7 @@ ;;;; compiler constants (setf *backend-fasl-file-type* "axpf") -(setf *backend-fasl-file-implementation* :alpha) -(setf *backend-fasl-file-version* 2) -;;;(setf *backend-fasl-file-version* 8) -;;; 8 = sbcl-0.6.10.4 revived Gray stream support, changing stream layouts +(defconstant +backend-fasl-file-implementation+ :alpha) (setf *backend-register-save-penalty* 3) diff --git a/src/compiler/alpha/nlx.lisp b/src/compiler/alpha/nlx.lisp index bb06154..3fd46b2 100644 --- a/src/compiler/alpha/nlx.lisp +++ b/src/compiler/alpha/nlx.lisp @@ -50,12 +50,12 @@ (eval :scs (descriptor-reg))) (:vop-var vop) (:generator 13 - (load-symbol-value catch sb!impl::*current-catch-block*) + (load-symbol-value catch *current-catch-block*) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst mskll cur-nfp 4 nfp))) (inst mskll nsp-tn 4 nsp) - (load-symbol-value eval sb!impl::*eval-stack-top*))) + (load-symbol-value eval *eval-stack-top*))) (define-vop (restore-dynamic-state) (:args (catch :scs (descriptor-reg)) @@ -65,8 +65,8 @@ (:vop-var vop) (:temporary (:sc any-reg) temp) (:generator 10 - (store-symbol-value catch sb!impl::*current-catch-block*) - (store-symbol-value eval sb!impl::*eval-stack-top*) + (store-symbol-value catch *current-catch-block*) + (store-symbol-value eval *eval-stack-top*) (inst mskll nsp-tn 0 temp) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -95,7 +95,7 @@ (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 22 (inst lda block (* (tn-offset tn) sb!vm:word-bytes) cfp-tn) - (load-symbol-value temp sb!impl::*current-unwind-protect-block*) + (load-symbol-value temp *current-unwind-protect-block*) (storew temp block sb!vm:unwind-block-current-uwp-slot) (storew cfp-tn block sb!vm:unwind-block-current-cont-slot) (storew code-tn block sb!vm:unwind-block-current-code-slot) @@ -115,7 +115,7 @@ (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 44 (inst lda result (* (tn-offset tn) sb!vm:word-bytes) cfp-tn) - (load-symbol-value temp sb!impl::*current-unwind-protect-block*) + (load-symbol-value temp *current-unwind-protect-block*) (storew temp result sb!vm:catch-block-current-uwp-slot) (storew cfp-tn result sb!vm:catch-block-current-cont-slot) (storew code-tn result sb!vm:catch-block-current-code-slot) @@ -123,9 +123,9 @@ (storew temp result sb!vm:catch-block-entry-pc-slot) (storew tag result sb!vm:catch-block-tag-slot) - (load-symbol-value temp sb!impl::*current-catch-block*) + (load-symbol-value temp *current-catch-block*) (storew temp result sb!vm:catch-block-previous-catch-slot) - (store-symbol-value result sb!impl::*current-catch-block*) + (store-symbol-value result *current-catch-block*) (move result block))) @@ -136,26 +136,25 @@ (:temporary (:scs (descriptor-reg)) new-uwp) (:generator 7 (inst lda new-uwp (* (tn-offset tn) sb!vm:word-bytes) cfp-tn) - (store-symbol-value new-uwp sb!impl::*current-unwind-protect-block*))) - + (store-symbol-value new-uwp *current-unwind-protect-block*))) (define-vop (unlink-catch-block) (:temporary (:scs (any-reg)) block) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 - (load-symbol-value block sb!impl::*current-catch-block*) + (load-symbol-value block *current-catch-block*) (loadw block block sb!vm:catch-block-previous-catch-slot) - (store-symbol-value block sb!impl::*current-catch-block*))) + (store-symbol-value block *current-catch-block*))) (define-vop (unlink-unwind-protect) (:temporary (:scs (any-reg)) block) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 - (load-symbol-value block sb!impl::*current-unwind-protect-block*) + (load-symbol-value block *current-unwind-protect-block*) (loadw block block sb!vm:unwind-block-current-uwp-slot) - (store-symbol-value block sb!impl::*current-unwind-protect-block*))) + (store-symbol-value block *current-unwind-protect-block*))) ;;;; NLX entry VOPs diff --git a/src/compiler/alpha/parms.lisp b/src/compiler/alpha/parms.lisp index c618478..55511ad 100644 --- a/src/compiler/alpha/parms.lisp +++ b/src/compiler/alpha/parms.lisp @@ -169,12 +169,11 @@ sb!impl::*!initial-fdefn-objects* ;; Functions that the C code needs to call - sb!impl::%initial-function - sb!impl::maybe-gc + maybe-gc sb!kernel::internal-error sb!di::handle-breakpoint sb!di::handle-function-end-breakpoint - sb!impl::fdefinition-object + fdefinition-object ;; free Pointers *read-only-space-free-pointer* @@ -182,12 +181,12 @@ *initial-dynamic-space-free-pointer* ;; things needed for non-local exit - sb!impl::*current-catch-block* - sb!impl::*current-unwind-protect-block* - sb!c::*eval-stack-top* + *current-catch-block* + *current-unwind-protect-block* + *eval-stack-top* ;; interrupt handling - sb!impl::*free-interrupt-context-index* + *free-interrupt-context-index* sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)) diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index 837baf9..6c0c529 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -23,19 +23,8 @@ ;;;; miscellaneous backend properties -;;; the conventional file extension for fasl files on this architecture, -;;; e.g. "x86f" -(defvar *backend-fasl-file-type* nil) -(declaim (type (or simple-string null) *backend-fasl-file-type*)) - -;;; implementation and version of fasl files used -(defvar *backend-fasl-file-implementation* nil) -(defvar *backend-fasl-file-version* nil) -(declaim (type (or keyword null) *backend-fasl-file-implementation*)) -(declaim (type (or index null) *backend-fasl-file-version*)) - -;;; the number of references that a TN must have to offset the overhead of -;;; saving the TN across a call +;;; the number of references that a TN must have to offset the +;;; overhead of saving the TN across a call (defvar *backend-register-save-penalty* 0) (declaim (type index *backend-register-save-penalty*)) @@ -242,8 +231,3 @@ ;;; the VM support routines (defvar *backend-support-routines* (make-vm-support-routines)) (declaim (type vm-support-routines *backend-support-routines*)) - -;;;; utilities - -(defun backend-byte-fasl-file-implementation () - *backend-byte-order*) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index cc8a999..fedaa89 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -12,12 +12,6 @@ (in-package "SB!C") -;;;; the fasl file format that we use -(defconstant byte-fasl-file-version 3) -;;; 1 = before about sbcl-0.6.9.8 -;;; 2 = merged package SB-CONDITIONS into SB-KERNEL around sbcl-0.6.9.8 -;;; 3 = deleted obsolete CONS-UNIQUE-TAG bytecode in sbcl-0.6.11.8 - ;;; ### remaining work: ;;; ;;; - add more inline operations. @@ -1977,7 +1971,7 @@ (describe-byte-component component xeps segment *compiler-trace-output*)) (etypecase *compile-object* - (fasl-file + (fasl-output (maybe-mumble "FASL") (fasl-dump-byte-component segment code-length constants xeps *compile-object*)) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index d17167c..ba1aaa2 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -9,23 +9,23 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!C") - -;;; FIXME: Double colons are bad, and there are lots of them in this -;;; file, because both dump logic in SB!C and load logic in SB!IMPL -;;; need to know about fops. Perhaps all the load/dump logic should be -;;; moved into a single package, perhaps called SB-LD. +(in-package "SB!FASL") +;;; KLUDGE: Even though we're IN-PACKAGE SB!FASL, some of the code in +;;; here is awfully chummy with the SB!C package. CMU CL didn't have +;;; any separation between the two packages, and a lot of tight +;;; coupling remains. -- WHN 2001-06-04 ;;;; fasl dumper state -;;; The FASL-FILE structure represents everything we need to know -;;; about dumping to a fasl file. We need to objectify the state, -;;; since the fasdumper must be reentrant. -(defstruct (fasl-file +;;; The FASL-OUTPUT structure represents everything we need to +;;; know about dumping to a fasl file. (We need to objectify the +;;; state because the fasdumper must be reentrant.) +(defstruct (fasl-output #-no-ansi-print-object (:print-object (lambda (x s) (print-unreadable-object (x s :type t) - (prin1 (namestring (fasl-file-stream x)) s)))) + (prin1 (namestring (fasl-output-stream x)) + s)))) (:copier nil)) ;; the stream we dump to (stream (required-argument) :type stream) @@ -100,15 +100,16 @@ (defvar *dump-only-valid-structures* t) ;;;; utilities -;;; Write the byte B to the specified fasl-file stream. -(defun dump-byte (b fasl-file) - (declare (type (unsigned-byte 8) b) (type fasl-file fasl-file)) - (write-byte b (fasl-file-stream fasl-file))) +;;; Write the byte B to the specified FASL-OUTPUT stream. +(defun dump-byte (b fasl-output) + (declare (type (unsigned-byte 8) b) (type fasl-output fasl-output)) + (write-byte b (fasl-output-stream fasl-output))) ;;; Dump a 4 byte unsigned integer. -(defun dump-unsigned-32 (num fasl-file) - (declare (type (unsigned-byte 32) num) (type fasl-file fasl-file)) - (let ((stream (fasl-file-stream fasl-file))) +(defun dump-unsigned-32 (num fasl-output) + (declare (type (unsigned-byte 32) num)) + (declare (type fasl-output fasl-output)) + (let ((stream (fasl-output-stream fasl-output))) (dotimes (i 4) (write-byte (ldb (byte 8 (* 8 i)) num) stream)))) @@ -116,13 +117,14 @@ ;;; for either signed or unsigned integers. There's no range checking ;;; -- if you don't specify enough bytes for the number to fit, this ;;; function cheerfully outputs the low bytes. -(defun dump-integer-as-n-bytes (num bytes file) - (declare (integer num) (type index bytes) (type fasl-file file)) +(defun dump-integer-as-n-bytes (num bytes fasl-output) + (declare (integer num) (type index bytes)) + (declare (type fasl-output fasl-output)) (do ((n num (ash n -8)) (i bytes (1- i))) ((= i 0)) (declare (type index i)) - (dump-byte (logand n #xff) file)) + (dump-byte (logand n #xff) fasl-output)) (values)) ;;; Setting this variable to an (UNSIGNED-BYTE 32) value causes @@ -133,7 +135,7 @@ #!+sb-show (defvar *fop-nop4-count* nil) #!+sb-show (declaim (type (or (unsigned-byte 32) null) *fop-nop4-count*)) -;;; Dump the FOP code for the named FOP to the specified fasl-file. +;;; Dump the FOP code for the named FOP to the specified FASL-OUTPUT. ;;; ;;; FIXME: This should be a function, with a compiler macro expansion ;;; for the common constant-FS case. (Among other things, that'll stop @@ -143,12 +145,12 @@ ;;; optimizations should be conditional on #!+SB-FROZEN. (defmacro dump-fop (fs file) (let* ((fs (eval fs)) - (val (get fs 'sb!impl::fop-code))) + (val (get fs 'fop-code))) (if val `(progn #!+sb-show (when *fop-nop4-count* - (dump-byte ,(get 'sb!impl::fop-nop4 'sb!impl::fop-code) ,file) + (dump-byte ,(get 'fop-nop4 'fop-code) ,file) (dump-unsigned-32 (mod (incf *fop-nop4-count*) (expt 2 32)) ,file)) (dump-byte ',val ,file)) (error "compiler bug: ~S is not a legal fasload operator." fs)))) @@ -169,28 +171,28 @@ (dump-unsigned-32 ,n-n ,n-file))))) ;;; Push the object at table offset Handle on the fasl stack. -(defun dump-push (handle file) - (declare (type index handle) (type fasl-file file)) - (dump-fop* handle sb!impl::fop-byte-push sb!impl::fop-push file) +(defun dump-push (handle fasl-output) + (declare (type index handle) (type fasl-output fasl-output)) + (dump-fop* handle fop-byte-push fop-push fasl-output) (values)) ;;; Pop the object currently on the fasl stack top into the table, and ;;; return the table index, incrementing the free pointer. -(defun dump-pop (file) +(defun dump-pop (fasl-output) (prog1 - (fasl-file-table-free file) - (dump-fop 'sb!impl::fop-pop file) - (incf (fasl-file-table-free file)))) + (fasl-output-table-free fasl-output) + (dump-fop 'fop-pop fasl-output) + (incf (fasl-output-table-free fasl-output)))) ;;; If X is in File's EQUAL-TABLE, then push the object and return T, ;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and ;;; return NIL. -(defun equal-check-table (x file) - (declare (type fasl-file file)) +(defun equal-check-table (x fasl-output) + (declare (type fasl-output fasl-output)) (unless *cold-load-dump* - (let ((handle (gethash x (fasl-file-equal-table file)))) + (let ((handle (gethash x (fasl-output-equal-table fasl-output)))) (cond (handle - (dump-push handle file) + (dump-push handle fasl-output) t) (t nil))))) @@ -199,20 +201,20 @@ ;;; object in the table. The object (also passed in as X) must already ;;; be on the top of the FOP stack. If *COLD-LOAD-DUMP* is true, then ;;; we don't do anything. -(defun eq-save-object (x file) - (declare (type fasl-file file)) +(defun eq-save-object (x fasl-output) + (declare (type fasl-output fasl-output)) (unless *cold-load-dump* - (let ((handle (dump-pop file))) - (setf (gethash x (fasl-file-eq-table file)) handle) - (dump-push handle file))) + (let ((handle (dump-pop fasl-output))) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output))) (values)) -(defun equal-save-object (x file) - (declare (type fasl-file file)) +(defun equal-save-object (x fasl-output) + (declare (type fasl-output fasl-output)) (unless *cold-load-dump* - (let ((handle (dump-pop file))) - (setf (gethash x (fasl-file-equal-table file)) handle) - (setf (gethash x (fasl-file-eq-table file)) handle) - (dump-push handle file))) + (let ((handle (dump-pop fasl-output))) + (setf (gethash x (fasl-output-equal-table fasl-output)) handle) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output))) (values)) ;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is @@ -223,9 +225,9 @@ ;;; should never be recursively called on a circular reference. ;;; Instead, the dumping function must detect the circularity and ;;; arrange for the dumped object to be patched. -(defun note-potential-circularity (x file) +(defun note-potential-circularity (x fasl-output) (unless *cold-load-dump* - (let ((circ (fasl-file-circularity-table file))) + (let ((circ (fasl-output-circularity-table fasl-output))) (aver (not (gethash x circ))) (setf (gethash x circ) x))) (values)) @@ -233,33 +235,33 @@ ;;; Dump FORM to a fasl file so that it evaluated at load time in normal ;;; load and at cold-load time in cold load. This is used to dump package ;;; frobbing forms. -(defun fasl-dump-cold-load-form (form file) - (declare (type fasl-file file)) - (dump-fop 'sb!impl::fop-normal-load file) +(defun fasl-dump-cold-load-form (form fasl-output) + (declare (type fasl-output fasl-output)) + (dump-fop 'fop-normal-load fasl-output) (let ((*cold-load-dump* t)) - (dump-object form file)) - (dump-fop 'sb!impl::fop-eval-for-effect file) - (dump-fop 'sb!impl::fop-maybe-cold-load file) + (dump-object form fasl-output)) + (dump-fop 'fop-eval-for-effect fasl-output) + (dump-fop 'fop-maybe-cold-load fasl-output) (values)) ;;;; opening and closing fasl files -;;; Open a fasl file, write its header, and return a FASL-FILE object -;;; for dumping to it. Some human-readable information about the -;;; source code is given by the string WHERE. If BYTE-P is true, this -;;; file will contain no native code, and is thus largely +;;; Open a fasl file, write its header, and return a FASL-OUTPUT +;;; object for dumping to it. Some human-readable information about +;;; the source code is given by the string WHERE. If BYTE-P is true, +;;; this file will contain no native code, and is thus largely ;;; implementation independent. -(defun open-fasl-file (name where &optional byte-p) +(defun open-fasl-output (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type 'sb!assem:assembly-unit)) - (res (make-fasl-file :stream stream))) + (res (make-fasl-output :stream stream))) ;; Begin the header with the constant machine-readable (and ;; semi-human-readable) string which is used to identify fasl files. - (write-string sb!c:*fasl-header-string-start-string* stream) + (write-string *fasl-header-string-start-string* stream) ;; The constant string which begins the header is followed by ;; arbitrary human-readable text, terminated by a special @@ -276,33 +278,36 @@ (machine-instance) (sb!xc:lisp-implementation-type) (sb!xc:lisp-implementation-version))) - (dump-byte sb!c:*fasl-header-string-stop-char-code* res) + (dump-byte +fasl-header-string-stop-char-code+ res) ;; Finish the header by outputting fasl file implementation and ;; version in machine-readable form. - (multiple-value-bind (implementation version) - (if byte-p - (values *backend-byte-order* - byte-fasl-file-version) - (values *backend-fasl-file-implementation* - *backend-fasl-file-version*)) + (let ((implementation (if byte-p + (backend-byte-fasl-file-implementation) + +backend-fasl-file-implementation+))) (dump-unsigned-32 (length (symbol-name implementation)) res) (dotimes (i (length (symbol-name implementation))) - (dump-byte (char-code (aref (symbol-name implementation) i)) res)) - (dump-unsigned-32 version res)) + (dump-byte (char-code (aref (symbol-name implementation) i)) res))) + (dump-unsigned-32 +fasl-file-version+ res) res)) -;;; Close the specified FASL-FILE, aborting the write if ABORT-P. -;;; We do various sanity checks, then end the group. -(defun close-fasl-file (file abort-p) - (declare (type fasl-file file)) - (aver (zerop (hash-table-count (fasl-file-patch-table file)))) - (dump-fop 'sb!impl::fop-verify-empty-stack file) - (dump-fop 'sb!impl::fop-verify-table-size file) - (dump-unsigned-32 (fasl-file-table-free file) file) - (dump-fop 'sb!impl::fop-end-group file) - (close (fasl-file-stream file) :abort abort-p) +;;; Close the specified FASL-OUTPUT, aborting the write if ABORT-P. +(defun close-fasl-output (fasl-output abort-p) + (declare (type fasl-output fasl-output)) + + ;; sanity checks + (aver (zerop (hash-table-count (fasl-output-patch-table fasl-output)))) + + ;; End the group. + (dump-fop 'fop-verify-empty-stack fasl-output) + (dump-fop 'fop-verify-table-size fasl-output) + (dump-unsigned-32 (fasl-output-table-free fasl-output) + fasl-output) + (dump-fop 'fop-end-group fasl-output) + + ;; That's all, folks. + (close (fasl-output-stream fasl-output) :abort abort-p) (values)) ;;;; main entries to object dumping @@ -316,7 +321,7 @@ ;;; ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE. (defun dump-non-immediate-object (x file) - (let ((index (gethash x (fasl-file-eq-table file)))) + (let ((index (gethash x (fasl-output-eq-table file)))) (cond ((and index (not *cold-load-dump*)) (dump-push index file)) (t @@ -382,10 +387,10 @@ (cond ((listp x) (if x (dump-non-immediate-object x file) - (dump-fop 'sb!impl::fop-empty-list file))) + (dump-fop 'fop-empty-list file))) ((symbolp x) (if (eq x t) - (dump-fop 'sb!impl::fop-truth file) + (dump-fop 'fop-truth file) (dump-non-immediate-object x file))) ((fixnump x) (dump-integer x file)) ((characterp x) (dump-character x file)) @@ -398,8 +403,9 @@ ;;; fetching the enclosing object from the table, and then CDR'ing it ;;; if necessary. (defun dump-circularities (infos file) - (let ((table (fasl-file-eq-table file))) + (let ((table (fasl-output-eq-table file))) (dolist (info infos) + (let* ((value (circularity-value info)) (enclosing (circularity-enclosing-object info))) (dump-push (gethash enclosing table) file) @@ -407,21 +413,21 @@ (do ((current enclosing (cdr current)) (i 0 (1+ i))) ((eq current value) - (dump-fop 'sb!impl::fop-nthcdr file) + (dump-fop 'fop-nthcdr file) (dump-unsigned-32 i file)) (declare (type index i))))) (ecase (circularity-type info) - (:rplaca (dump-fop 'sb!impl::fop-rplaca file)) - (:rplacd (dump-fop 'sb!impl::fop-rplacd file)) - (:svset (dump-fop 'sb!impl::fop-svset file)) - (:struct-set (dump-fop 'sb!impl::fop-structset file))) + (:rplaca (dump-fop 'fop-rplaca file)) + (:rplacd (dump-fop 'fop-rplacd file)) + (:svset (dump-fop 'fop-svset file)) + (:struct-set (dump-fop 'fop-structset file))) (dump-unsigned-32 (gethash (circularity-object info) table) file) (dump-unsigned-32 (circularity-index info) file)))) ;;; Set up stuff for circularity detection, then dump an object. All ;;; shared and circular structure will be exactly preserved within a -;;; single call to Dump-Object. Sharing between objects dumped by +;;; single call to DUMP-OBJECT. Sharing between objects dumped by ;;; separate calls is only preserved when convenient. ;;; ;;; We peek at the object type so that we only pay the circular @@ -432,7 +438,7 @@ (consp x) (typep x 'instance)) (let ((*circularities-detected* ()) - (circ (fasl-file-circularity-table file))) + (circ (fasl-output-circularity-table file))) (clrhash circ) (sub-dump-object x file) (when *circularities-detected* @@ -445,26 +451,27 @@ ;;; Emit a funcall of the function and return the handle for the ;;; result. (defun fasl-dump-load-time-value-lambda (fun file) - (declare (type clambda fun) (type fasl-file file)) - (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) + (declare (type sb!c::clambda fun) (type fasl-output file)) + (let ((handle (gethash (sb!c::leaf-info fun) + (fasl-output-entry-table file)))) (aver handle) (dump-push handle file) - (dump-fop 'sb!impl::fop-funcall file) + (dump-fop 'fop-funcall file) (dump-byte 0 file)) (dump-pop file)) ;;; Return T iff CONSTANT has not already been dumped. It's been ;;; dumped if it's in the EQ table. -(defun fasl-constant-already-dumped (constant file) - (if (or (gethash constant (fasl-file-eq-table file)) - (gethash constant (fasl-file-valid-structures file))) +(defun fasl-constant-already-dumped-p (constant file) + (if (or (gethash constant (fasl-output-eq-table file)) + (gethash constant (fasl-output-valid-structures file))) t nil)) ;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been ;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA. (defun fasl-note-handle-for-constant (constant handle file) - (let ((table (fasl-file-eq-table file))) + (let ((table (fasl-output-eq-table file))) (when (gethash constant table) (error "~S already dumped?" constant)) (setf (gethash constant table) handle)) @@ -473,7 +480,7 @@ ;;; Note that the specified structure can just be dumped by ;;; enumerating the slots. (defun fasl-validate-structure (structure file) - (setf (gethash structure (fasl-file-valid-structures file)) t) + (setf (gethash structure (fasl-output-valid-structures file)) t) (values)) ;;;; number dumping @@ -482,35 +489,32 @@ (defun dump-ratio (x file) (sub-dump-object (numerator x) file) (sub-dump-object (denominator x) file) - (dump-fop 'sb!impl::fop-ratio file)) + (dump-fop 'fop-ratio file)) ;;; Dump an integer. (defun dump-integer (n file) (typecase n ((signed-byte 8) - (dump-fop 'sb!impl::fop-byte-integer file) + (dump-fop 'fop-byte-integer file) (dump-byte (logand #xFF n) file)) ((unsigned-byte 31) - (dump-fop 'sb!impl::fop-word-integer file) + (dump-fop 'fop-word-integer file) (dump-unsigned-32 n file)) ((signed-byte 32) - (dump-fop 'sb!impl::fop-word-integer file) + (dump-fop 'fop-word-integer file) (dump-integer-as-n-bytes n 4 file)) (t (let ((bytes (ceiling (1+ (integer-length n)) 8))) - (dump-fop* bytes - sb!impl::fop-small-integer - sb!impl::fop-integer - file) + (dump-fop* bytes fop-small-integer fop-integer file) (dump-integer-as-n-bytes n bytes file))))) (defun dump-float (x file) (etypecase x (single-float - (dump-fop 'sb!impl::fop-single-float file) + (dump-fop 'fop-single-float file) (dump-integer-as-n-bytes (single-float-bits x) 4 file)) (double-float - (dump-fop 'sb!impl::fop-double-float file) + (dump-fop 'fop-double-float file) (let ((x x)) (declare (double-float x)) ;; FIXME: Why sometimes DUMP-UNSIGNED-32 and sometimes @@ -519,19 +523,19 @@ (dump-integer-as-n-bytes (double-float-high-bits x) 4 file))) #!+long-float (long-float - (dump-fop 'sb!impl::fop-long-float file) + (dump-fop 'fop-long-float file) (dump-long-float x file)))) (defun dump-complex (x file) (typecase x #-sb-xc-host ((complex single-float) - (dump-fop 'sb!impl::fop-complex-single-float file) + (dump-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)) #-sb-xc-host ((complex double-float) - (dump-fop 'sb!impl::fop-complex-double-float file) + (dump-fop 'fop-complex-double-float file) (let ((re (realpart x))) (declare (double-float re)) (dump-unsigned-32 (double-float-low-bits re) file) @@ -542,13 +546,13 @@ (dump-integer-as-n-bytes (double-float-high-bits im) 4 file))) #!+(and long-float (not sb-xc)) ((complex long-float) - (dump-fop 'sb!impl::fop-complex-long-float file) + (dump-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 'sb!impl::fop-complex file)))) + (dump-fop 'fop-complex file)))) ;;;; symbol dumping @@ -561,18 +565,19 @@ ;;; DUMP-SYMBOL and DUMP-LIST. The mapping between names and behavior ;;; should be made more consistent. (defun dump-package (pkg file) - (declare (type package pkg) (type fasl-file file) (values index) - (inline assoc)) - (cond ((cdr (assoc pkg (fasl-file-packages file) :test #'eq))) + (declare (type package pkg) (type fasl-output file)) + (declare (values index)) + (declare (inline assoc)) + (cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq))) (t (unless *cold-load-dump* - (dump-fop 'sb!impl::fop-normal-load file)) + (dump-fop 'fop-normal-load file)) (dump-simple-string (package-name pkg) file) - (dump-fop 'sb!impl::fop-package file) + (dump-fop 'fop-package file) (unless *cold-load-dump* - (dump-fop 'sb!impl::fop-maybe-cold-load file)) + (dump-fop 'fop-maybe-cold-load file)) (let ((entry (dump-pop file))) - (push (cons pkg entry) (fasl-file-packages file)) + (push (cons pkg entry) (fasl-output-packages file)) entry)))) ;;; dumper for lists @@ -596,10 +601,10 @@ ;;; This inhibits all circularity detection. (defun dump-list (list file) (aver (and list - (not (gethash list (fasl-file-circularity-table file))))) + (not (gethash list (fasl-output-circularity-table file))))) (do* ((l list (cdr l)) (n 0 (1+ n)) - (circ (fasl-file-circularity-table file))) + (circ (fasl-output-circularity-table file))) ((atom l) (cond ((null l) (terminate-undotted-list n file)) @@ -635,49 +640,49 @@ (sub-dump-object obj file)))))) (defun terminate-dotted-list (n file) - (declare (type index n) (type fasl-file file)) + (declare (type index n) (type fasl-output file)) (case n - (1 (dump-fop 'sb!impl::fop-list*-1 file)) - (2 (dump-fop 'sb!impl::fop-list*-2 file)) - (3 (dump-fop 'sb!impl::fop-list*-3 file)) - (4 (dump-fop 'sb!impl::fop-list*-4 file)) - (5 (dump-fop 'sb!impl::fop-list*-5 file)) - (6 (dump-fop 'sb!impl::fop-list*-6 file)) - (7 (dump-fop 'sb!impl::fop-list*-7 file)) - (8 (dump-fop 'sb!impl::fop-list*-8 file)) + (1 (dump-fop 'fop-list*-1 file)) + (2 (dump-fop 'fop-list*-2 file)) + (3 (dump-fop 'fop-list*-3 file)) + (4 (dump-fop 'fop-list*-4 file)) + (5 (dump-fop 'fop-list*-5 file)) + (6 (dump-fop 'fop-list*-6 file)) + (7 (dump-fop 'fop-list*-7 file)) + (8 (dump-fop 'fop-list*-8 file)) (T (do ((nn n (- nn 255))) ((< nn 256) - (dump-fop 'sb!impl::fop-list* file) + (dump-fop 'fop-list* file) (dump-byte nn file)) (declare (type index nn)) - (dump-fop 'sb!impl::fop-list* file) + (dump-fop 'fop-list* file) (dump-byte 255 file))))) ;;; If N > 255, must build list with one LIST operator, then LIST* ;;; operators. (defun terminate-undotted-list (n file) - (declare (type index n) (type fasl-file file)) + (declare (type index n) (type fasl-output file)) (case n - (1 (dump-fop 'sb!impl::fop-list-1 file)) - (2 (dump-fop 'sb!impl::fop-list-2 file)) - (3 (dump-fop 'sb!impl::fop-list-3 file)) - (4 (dump-fop 'sb!impl::fop-list-4 file)) - (5 (dump-fop 'sb!impl::fop-list-5 file)) - (6 (dump-fop 'sb!impl::fop-list-6 file)) - (7 (dump-fop 'sb!impl::fop-list-7 file)) - (8 (dump-fop 'sb!impl::fop-list-8 file)) + (1 (dump-fop 'fop-list-1 file)) + (2 (dump-fop 'fop-list-2 file)) + (3 (dump-fop 'fop-list-3 file)) + (4 (dump-fop 'fop-list-4 file)) + (5 (dump-fop 'fop-list-5 file)) + (6 (dump-fop 'fop-list-6 file)) + (7 (dump-fop 'fop-list-7 file)) + (8 (dump-fop 'fop-list-8 file)) (T (cond ((< n 256) - (dump-fop 'sb!impl::fop-list file) + (dump-fop 'fop-list file) (dump-byte n file)) - (t (dump-fop 'sb!impl::fop-list file) + (t (dump-fop 'fop-list file) (dump-byte 255 file) (do ((nn (- n 255) (- nn 255))) ((< nn 256) - (dump-fop 'sb!impl::fop-list* file) + (dump-fop 'fop-list* file) (dump-byte nn file)) (declare (type index nn)) - (dump-fop 'sb!impl::fop-list* file) + (dump-fop 'fop-list* file) (dump-byte 255 file))))))) ;;;; array dumping @@ -729,16 +734,13 @@ ;;; Dump a SIMPLE-VECTOR, handling any circularities. (defun dump-simple-vector (v file) - (declare (type simple-vector v) (type fasl-file file)) + (declare (type simple-vector v) (type fasl-output file)) (note-potential-circularity v file) (do ((index 0 (1+ index)) (length (length v)) - (circ (fasl-file-circularity-table file))) + (circ (fasl-output-circularity-table file))) ((= index length) - (dump-fop* length - sb!impl::fop-small-vector - sb!impl::fop-vector - file)) + (dump-fop* length fop-small-vector fop-vector file)) (let* ((obj (aref v index)) (ref (gethash obj circ))) (cond (ref @@ -757,7 +759,7 @@ (let ((len (length vec))) (labels ((dump-unsigned-vector (size bytes) (unless data-only - (dump-fop 'sb!impl::fop-int-vector file) + (dump-fop 'fop-int-vector file) (dump-unsigned-32 len file) (dump-byte size file)) ;; The case which is easy to handle in a portable way is when @@ -781,7 +783,7 @@ ;; provided in the cross-compilation host, only on the ;; target machine.) (unless data-only - (dump-fop 'sb!impl::fop-signed-int-vector file) + (dump-fop 'fop-signed-int-vector file) (dump-unsigned-32 len file) (dump-byte size file)) (dump-raw-bytes vec bytes file))) @@ -811,24 +813,21 @@ ;;; Dump characters and string-ish things. (defun dump-character (ch file) - (dump-fop 'sb!impl::fop-short-character file) + (dump-fop 'fop-short-character file) (dump-byte (char-code ch) file)) ;;; a helper function shared by DUMP-SIMPLE-STRING and DUMP-SYMBOL -(defun dump-characters-of-string (s fasl-file) - (declare (type string s) (type fasl-file fasl-file)) +(defun dump-characters-of-string (s fasl-output) + (declare (type string s) (type fasl-output fasl-output)) (dovector (c s) - (dump-byte (char-code c) fasl-file)) + (dump-byte (char-code c) fasl-output)) (values)) ;;; Dump a SIMPLE-BASE-STRING. ;;; FIXME: should be called DUMP-SIMPLE-BASE-STRING then (defun dump-simple-string (s file) (declare (type simple-base-string s)) - (dump-fop* (length s) - sb!impl::fop-small-string - sb!impl::fop-string - file) + (dump-fop* (length s) fop-small-string fop-string file) (dump-characters-of-string s file) (values)) @@ -838,14 +837,15 @@ ;;; table, but don't record that we have done so if *COLD-LOAD-DUMP* ;;; is true. (defun dump-symbol (s file) + (declare (type fasl-output file)) (let* ((pname (symbol-name s)) (pname-length (length pname)) (pkg (symbol-package s))) (cond ((null pkg) (dump-fop* pname-length - sb!impl::fop-uninterned-small-symbol-save - sb!impl::fop-uninterned-symbol-save + fop-uninterned-small-symbol-save + fop-uninterned-symbol-save file)) ;; CMU CL had FOP-SYMBOL-SAVE/FOP-SMALL-SYMBOL-SAVE fops which ;; used the current value of *PACKAGE*. Unfortunately that's @@ -853,47 +853,47 @@ ;; from SBCL. ;;((eq pkg *package*) ;; (dump-fop* pname-length - ;; sb!impl::fop-small-symbol-save - ;; sb!impl::fop-symbol-save file)) + ;; fop-small-symbol-save + ;; fop-symbol-save file)) ((eq pkg sb!int:*cl-package*) (dump-fop* pname-length - sb!impl::fop-lisp-small-symbol-save - sb!impl::fop-lisp-symbol-save + fop-lisp-small-symbol-save + fop-lisp-symbol-save file)) ((eq pkg sb!int:*keyword-package*) (dump-fop* pname-length - sb!impl::fop-keyword-small-symbol-save - sb!impl::fop-keyword-symbol-save + fop-keyword-small-symbol-save + fop-keyword-symbol-save file)) ((< pname-length 256) (dump-fop* (dump-package pkg file) - sb!impl::fop-small-symbol-in-byte-package-save - sb!impl::fop-small-symbol-in-package-save + fop-small-symbol-in-byte-package-save + fop-small-symbol-in-package-save file) (dump-byte pname-length file)) (t (dump-fop* (dump-package pkg file) - sb!impl::fop-symbol-in-byte-package-save - sb!impl::fop-symbol-in-package-save + fop-symbol-in-byte-package-save + fop-symbol-in-package-save file) (dump-unsigned-32 pname-length file))) (dump-characters-of-string pname file) (unless *cold-load-dump* - (setf (gethash s (fasl-file-eq-table file)) - (fasl-file-table-free file))) + (setf (gethash s (fasl-output-eq-table file)) + (fasl-output-table-free file))) - (incf (fasl-file-table-free file))) + (incf (fasl-output-table-free file))) (values)) ;;;; component (function) dumping -(defun dump-segment (segment code-length fasl-file) +(defun dump-segment (segment code-length fasl-output) (declare (type sb!assem:segment segment) - (type fasl-file fasl-file)) - (let* ((stream (fasl-file-stream fasl-file)) + (type fasl-output fasl-output)) + (let* ((stream (fasl-output-stream fasl-output)) (nwritten (write-segment-contents segment stream))) ;; In CMU CL there was no enforced connection between the CODE-LENGTH ;; argument and the number of bytes actually written. I added this @@ -910,15 +910,15 @@ ;; do either. -- WHN 19990323 #!+gengc (unless (zerop (logand code-length 3)) (dotimes (i (- 4 (logand code-length 3))) - (dump-byte 0 fasl-file))) + (dump-byte 0 fasl-output))) (values)) ;;; Dump all the fixups. Currently there are three flavors of fixup: ;;; - assembly routines: named by a symbol ;;; - foreign (C) symbols: named by a string ;;; - code object references: don't need a name. -(defun dump-fixups (fixups fasl-file) - (declare (list fixups) (type fasl-file fasl-file)) +(defun dump-fixups (fixups fasl-output) + (declare (list fixups) (type fasl-output fasl-output)) (dolist (info fixups) ;; FIXME: Packing data with LIST in NOTE-FIXUP and unpacking them ;; with FIRST, SECOND, and THIRD here is hard to follow and @@ -934,33 +934,33 @@ ;; I can tell, FIXUP-OFFSET is not actually an offset, it's an ;; internal label used instead of NAME for :CODE-OBJECT fixups. ;; Notice that in the :CODE-OBJECT case, NAME is ignored.) - (dump-fop 'sb!impl::fop-normal-load fasl-file) + (dump-fop 'fop-normal-load fasl-output) (let ((*cold-load-dump* t)) - (dump-object kind fasl-file)) - (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file) + (dump-object kind fasl-output)) + (dump-fop 'fop-maybe-cold-load fasl-output) ;; Depending on the flavor, we may have various kinds of ;; noise before the offset. (ecase flavor (:assembly-routine (aver (symbolp name)) - (dump-fop 'sb!impl::fop-normal-load fasl-file) + (dump-fop 'fop-normal-load fasl-output) (let ((*cold-load-dump* t)) - (dump-object name fasl-file)) - (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file) - (dump-fop 'sb!impl::fop-assembler-fixup fasl-file)) + (dump-object name fasl-output)) + (dump-fop 'fop-maybe-cold-load fasl-output) + (dump-fop 'fop-assembler-fixup fasl-output)) (:foreign (aver (stringp name)) - (dump-fop 'sb!impl::fop-foreign-fixup fasl-file) + (dump-fop 'fop-foreign-fixup fasl-output) (let ((len (length name))) (aver (< len 256)) ; (limit imposed by fop definition) - (dump-byte len fasl-file) + (dump-byte len fasl-output) (dotimes (i len) - (dump-byte (char-code (schar name i)) fasl-file)))) + (dump-byte (char-code (schar name i)) fasl-output)))) (:code-object (aver (null name)) - (dump-fop 'sb!impl::fop-code-object-fixup fasl-file))) + (dump-fop 'fop-code-object-fixup fasl-output))) ;; No matter what the flavor, we'll always dump the offset. - (dump-unsigned-32 offset fasl-file))) + (dump-unsigned-32 offset fasl-output))) (values)) ;;; Dump out the constant pool and code-vector for component, push the @@ -980,33 +980,34 @@ code-length trace-table-as-list fixups - fasl-file) + fasl-output) (declare (type component component) (list trace-table-as-list) (type index code-length) - (type fasl-file fasl-file)) + (type fasl-output fasl-output)) (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) + (constants (sb!c::ir2-component-constants 2comp)) (header-length (length constants)) (packed-trace-table (pack-trace-table trace-table-as-list)) (total-length (+ code-length - (* (length packed-trace-table) tt-bytes-per-entry)))) + (* (length packed-trace-table) + sb!c::tt-bytes-per-entry)))) (collect ((patches)) ;; Dump the debug info. #!+gengc - (let ((info (debug-info-for-component component)) + (let ((info (sb!c::debug-info-for-component component)) (*dump-only-valid-structures* nil)) - (dump-object info fasl-file) - (let ((info-handle (dump-pop fasl-file))) - (dump-push info-handle fasl-file) - (push info-handle (fasl-file-debug-info fasl-file)))) + (dump-object info fasl-output) + (let ((info-handle (dump-pop fasl-output))) + (dump-push info-handle fasl-output) + (push info-handle (fasl-output-debug-info fasl-output)))) ;; Dump the offset of the trace table. - (dump-object code-length fasl-file) + (dump-object code-length fasl-output) ;; FIXME: As long as we don't have GENGC, the trace table is ;; hardwired to be empty. So we might be able to get rid of ;; trace tables? However, we should probably wait for the first @@ -1020,35 +1021,36 @@ (let ((entry (aref constants i))) (etypecase entry (constant - (dump-object (constant-value entry) fasl-file)) + (dump-object (sb!c::constant-value entry) fasl-output)) (cons (ecase (car entry) (:entry - (let* ((info (leaf-info (cdr entry))) + (let* ((info (sb!c::leaf-info (cdr entry))) (handle (gethash info - (fasl-file-entry-table fasl-file)))) + (fasl-output-entry-table + fasl-output)))) (cond (handle - (dump-push handle fasl-file)) + (dump-push handle fasl-output)) (t (patches (cons info i)) - (dump-fop 'sb!impl::fop-misc-trap fasl-file))))) + (dump-fop 'fop-misc-trap fasl-output))))) (:load-time-value - (dump-push (cdr entry) fasl-file)) + (dump-push (cdr entry) fasl-output)) (:fdefinition - (dump-object (cdr entry) fasl-file) - (dump-fop 'sb!impl::fop-fdefinition fasl-file)))) + (dump-object (cdr entry) fasl-output) + (dump-fop 'fop-fdefinition fasl-output)))) (null - (dump-fop 'sb!impl::fop-misc-trap fasl-file))))) + (dump-fop 'fop-misc-trap fasl-output))))) ;; Dump the debug info. #!-gengc - (let ((info (debug-info-for-component component)) + (let ((info (sb!c::debug-info-for-component component)) (*dump-only-valid-structures* nil)) - (dump-object info fasl-file) - (let ((info-handle (dump-pop fasl-file))) - (dump-push info-handle fasl-file) - (push info-handle (fasl-file-debug-info fasl-file)))) + (dump-object info fasl-output) + (let ((info-handle (dump-pop fasl-output))) + (dump-push info-handle fasl-output) + (push info-handle (fasl-output-debug-info fasl-output)))) (let ((num-consts #!+gengc (- header-length sb!vm:code-debug-info-slot) @@ -1057,46 +1059,47 @@ (total-length #!+gengc (ceiling total-length 4) #!-gengc total-length)) (cond ((and (< num-consts #x100) (< total-length #x10000)) - (dump-fop 'sb!impl::fop-small-code fasl-file) - (dump-byte num-consts fasl-file) - (dump-integer-as-n-bytes total-length 2 fasl-file)) + (dump-fop 'fop-small-code fasl-output) + (dump-byte num-consts fasl-output) + (dump-integer-as-n-bytes total-length 2 fasl-output)) (t - (dump-fop 'sb!impl::fop-code fasl-file) - (dump-unsigned-32 num-consts fasl-file) - (dump-unsigned-32 total-length fasl-file)))) + (dump-fop 'fop-code fasl-output) + (dump-unsigned-32 num-consts fasl-output) + (dump-unsigned-32 total-length fasl-output)))) ;; These two dumps are only ones which contribute to our ;; TOTAL-LENGTH value. - (dump-segment code-segment code-length fasl-file) - (dump-i-vector packed-trace-table fasl-file :data-only t) + (dump-segment code-segment code-length fasl-output) + (dump-i-vector packed-trace-table fasl-output :data-only t) ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it ;; dumps aren't included in the TOTAL-LENGTH passed to our ;; FOP-CODE/FOP-SMALL-CODE fop. - (dump-fixups fixups fasl-file) + (dump-fixups fixups fasl-output) - (dump-fop 'sb!impl::fop-sanctify-for-execution fasl-file) - (let ((handle (dump-pop fasl-file))) + (dump-fop 'fop-sanctify-for-execution fasl-output) + (let ((handle (dump-pop fasl-output))) (dolist (patch (patches)) (push (cons handle (cdr patch)) - (gethash (car patch) (fasl-file-patch-table fasl-file)))) + (gethash (car patch) + (fasl-output-patch-table fasl-output)))) handle)))) (defun dump-assembler-routines (code-segment length fixups routines file) - (dump-fop 'sb!impl::fop-assembler-code file) + (dump-fop 'fop-assembler-code file) (dump-unsigned-32 #!+gengc (ceiling length 4) #!-gengc length file) - (write-segment-contents code-segment (fasl-file-stream file)) + (write-segment-contents code-segment (fasl-output-stream file)) (dolist (routine routines) - (dump-fop 'sb!impl::fop-normal-load file) + (dump-fop 'fop-normal-load file) (let ((*cold-load-dump* t)) (dump-object (car routine) file)) - (dump-fop 'sb!impl::fop-maybe-cold-load file) - (dump-fop 'sb!impl::fop-assembler-routine file) + (dump-fop 'fop-maybe-cold-load file) + (dump-fop 'fop-assembler-routine file) (dump-unsigned-32 (label-position (cdr routine)) file)) (dump-fixups fixups file) - (dump-fop 'sb!impl::fop-sanctify-for-execution file) + (dump-fop 'fop-sanctify-for-execution file) (dump-pop file)) ;;; Dump a function-entry data structure corresponding to ENTRY to @@ -1107,32 +1110,30 @@ ;;; cold loader can instantiate the definition at cold-load time, ;;; allowing forward references to functions in top-level forms. (defun dump-one-entry (entry code-handle file) - (declare (type entry-info entry) (type index code-handle) - (type fasl-file file)) - (let ((name (entry-info-name entry))) + (declare (type sb!c::entry-info entry) (type index code-handle) + (type fasl-output file)) + (let ((name (sb!c::entry-info-name entry))) (dump-push code-handle file) (dump-object name file) - (dump-object (entry-info-arguments entry) file) - (dump-object (entry-info-type entry) file) - (dump-fop 'sb!impl::fop-function-entry file) - (dump-unsigned-32 (label-position (entry-info-offset entry)) file) + (dump-object (sb!c::entry-info-arguments entry) file) + (dump-object (sb!c::entry-info-type entry) file) + (dump-fop 'fop-function-entry file) + (dump-unsigned-32 (label-position (sb!c::entry-info-offset entry)) file) (let ((handle (dump-pop file))) (when (and name (or (symbolp name) (listp name))) (dump-object name file) (dump-push handle file) - (dump-fop 'sb!impl::fop-fset file)) + (dump-fop 'fop-fset file)) handle))) ;;; Alter the code object referenced by CODE-HANDLE at the specified ;;; OFFSET, storing the object referenced by ENTRY-HANDLE. (defun dump-alter-code-object (code-handle offset entry-handle file) - (declare (type index code-handle entry-handle offset) (type fasl-file file)) + (declare (type index code-handle entry-handle offset)) + (declare (type fasl-output file)) (dump-push code-handle file) (dump-push entry-handle file) - (dump-fop* offset - sb!impl::fop-byte-alter-code - sb!impl::fop-alter-code - file) + (dump-fop* offset fop-byte-alter-code fop-alter-code file) (values)) ;;; Dump the code, constants, etc. for component. We pass in the @@ -1143,14 +1144,15 @@ trace-table fixups file) - (declare (type component component) (list trace-table) (type fasl-file file)) + (declare (type component component) (list trace-table)) + (declare (type fasl-output file)) - (dump-fop 'sb!impl::fop-verify-empty-stack file) - (dump-fop 'sb!impl::fop-verify-table-size file) - (dump-unsigned-32 (fasl-file-table-free file) file) + (dump-fop 'fop-verify-empty-stack file) + (dump-fop 'fop-verify-table-size file) + (dump-unsigned-32 (fasl-output-table-free file) file) #!+sb-dyncount - (let ((info (ir2-component-dyncount-info (component-info component)))) + (let ((info (sb!c::ir2-component-dyncount-info (component-info component)))) (when info (fasl-validate-structure info file))) @@ -1161,13 +1163,13 @@ fixups file)) (2comp (component-info component))) - (dump-fop 'sb!impl::fop-verify-empty-stack file) + (dump-fop 'fop-verify-empty-stack file) - (dolist (entry (ir2-component-entries 2comp)) + (dolist (entry (sb!c::ir2-component-entries 2comp)) (let ((entry-handle (dump-one-entry entry code-handle file))) - (setf (gethash entry (fasl-file-entry-table file)) entry-handle) + (setf (gethash entry (fasl-output-entry-table file)) entry-handle) - (let ((old (gethash entry (fasl-file-patch-table file)))) + (let ((old (gethash entry (fasl-output-patch-table file)))) ;; FIXME: All this code is shared with ;; FASL-DUMP-BYTE-COMPONENT, and should probably be gathered ;; up into a named function (DUMP-PATCHES?) called from both @@ -1178,25 +1180,25 @@ (cdr patch) entry-handle file)) - (remhash entry (fasl-file-patch-table file))))))) + (remhash entry (fasl-output-patch-table file))))))) (values)) (defun dump-byte-code-object (segment code-length constants file) (declare (type sb!assem:segment segment) (type index code-length) (type vector constants) - (type fasl-file file)) + (type fasl-output file)) (collect ((entry-patches)) ;; Dump the debug info. #!+gengc - (let ((info (make-debug-info - :name (component-name *component-being-compiled*))) + (let ((info (sb!c::make-debug-info + :name (sb!c::component-name *component-being-compiled*))) (*dump-only-valid-structures* nil)) (dump-object info file) (let ((info-handle (dump-pop file))) (dump-push info-handle file) - (push info-handle (fasl-file-debug-info file)))) + (push info-handle (fasl-output-debug-info file)))) ;; The "trace table" is initialized by loader to hold a list of ;; all byte functions in this code object (for debug info.) @@ -1207,79 +1209,65 @@ (let ((entry (aref constants i))) (etypecase entry (constant - (dump-object (constant-value entry) file)) + (dump-object (sb!c::constant-value entry) file)) (null - (dump-fop 'sb!impl::fop-misc-trap file)) + (dump-fop 'fop-misc-trap file)) (list (ecase (car entry) (:entry - (let* ((info (leaf-info (cdr entry))) - (handle (gethash info (fasl-file-entry-table file)))) + (let* ((info (sb!c::leaf-info (cdr entry))) + (handle (gethash info + (fasl-output-entry-table file)))) (cond (handle (dump-push handle file)) (t (entry-patches (cons info (+ i sb!vm:code-constants-offset))) - (dump-fop 'sb!impl::fop-misc-trap file))))) + (dump-fop 'fop-misc-trap file))))) (:load-time-value (dump-push (cdr entry) file)) (:fdefinition (dump-object (cdr entry) file) - (dump-fop 'sb!impl::fop-fdefinition file)) + (dump-fop 'fop-fdefinition file)) (:type-predicate (dump-object 'load-type-predicate file) (let ((*unparse-function-type-simplify* t)) (dump-object (type-specifier (cdr entry)) file)) - (dump-fop 'sb!impl::fop-funcall file) + (dump-fop 'fop-funcall file) (dump-byte 1 file))))))) ;; Dump the debug info. #!-gengc - (let ((info (make-debug-info :name - (component-name *component-being-compiled*))) + (let ((info (sb!c::make-debug-info :name + (sb!c::component-name + *component-being-compiled*))) (*dump-only-valid-structures* nil)) (dump-object info file) (let ((info-handle (dump-pop file))) (dump-push info-handle file) - (push info-handle (fasl-file-debug-info file)))) + (push info-handle (fasl-output-debug-info file)))) (let ((num-consts #!+gengc (+ (length constants) 2) #!-gengc (1+ (length constants))) (code-length #!+gengc (ceiling code-length 4) #!-gengc code-length)) (cond ((and (< num-consts #x100) (< code-length #x10000)) - (dump-fop 'sb!impl::fop-small-code file) + (dump-fop 'fop-small-code file) (dump-byte num-consts file) (dump-integer-as-n-bytes code-length 2 file)) (t - (dump-fop 'sb!impl::fop-code file) + (dump-fop 'fop-code file) (dump-unsigned-32 num-consts file) (dump-unsigned-32 code-length file)))) (dump-segment segment code-length file) (let ((code-handle (dump-pop file)) - (patch-table (fasl-file-patch-table file))) + (patch-table (fasl-output-patch-table file))) (dolist (patch (entry-patches)) (push (cons code-handle (cdr patch)) (gethash (car patch) patch-table))) code-handle))) -;;; Dump a BYTE-FUNCTION object. We dump the layout and -;;; funcallable-instance info, but rely on the loader setting up the -;;; correct funcallable-instance-function. -(defun dump-byte-function (xep code-handle file) - (let ((nslots (- (get-closure-length xep) - ;; 1- for header - (1- sb!vm:funcallable-instance-info-offset)))) - (dotimes (i nslots) - (if (zerop i) - (dump-push code-handle file) - (dump-object (%funcallable-instance-info xep i) file))) - (dump-object (%funcallable-instance-layout xep) file) - (dump-fop 'sb!impl::fop-make-byte-compiled-function file) - (dump-byte nslots file)) - (values)) - ;;; Dump a byte-component. This is similar to FASL-DUMP-COMPONENT, but ;;; different. (defun fasl-dump-byte-component (segment length constants xeps file) @@ -1287,18 +1275,19 @@ (type index length) (type vector constants) (type list xeps) - (type fasl-file file)) + (type fasl-output file)) (let ((code-handle (dump-byte-code-object segment length constants file))) (dolist (noise xeps) (let* ((lambda (car noise)) - (info (lambda-info lambda)) + (info (sb!c::lambda-info lambda)) (xep (cdr noise))) (dump-byte-function xep code-handle file) (let* ((entry-handle (dump-pop file)) - (patch-table (fasl-file-patch-table file)) + (patch-table (fasl-output-patch-table file)) (old (gethash info patch-table))) - (setf (gethash info (fasl-file-entry-table file)) entry-handle) + (setf (gethash info (fasl-output-entry-table file)) + entry-handle) (when old (dolist (patch old) (dump-alter-code-object (car patch) @@ -1311,49 +1300,46 @@ ;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at ;;; load time. (defun fasl-dump-top-level-lambda-call (fun file) - (declare (type clambda fun) (type fasl-file file)) - (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) + (declare (type sb!c::clambda fun) (type fasl-output file)) + (let ((handle (gethash (sb!c::leaf-info fun) + (fasl-output-entry-table file)))) (aver handle) (dump-push handle file) - (dump-fop 'sb!impl::fop-funcall-for-effect file) + (dump-fop 'fop-funcall-for-effect file) (dump-byte 0 file)) (values)) ;;; Compute the correct list of DEBUG-SOURCE structures and backpatch ;;; all of the dumped DEBUG-INFO structures. We clear the -;;; FASL-FILE-DEBUG-INFO, so that subsequent components with different -;;; source info may be dumped. +;;; FASL-OUTPUT-DEBUG-INFO, so that subsequent components with +;;; different source info may be dumped. (defun fasl-dump-source-info (info file) - (declare (type source-info info) (type fasl-file file)) - (let ((res (debug-source-for-info info)) + (declare (type sb!c::source-info info) (type fasl-output file)) + (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-file-debug-info file)) + (dolist (info-handle (fasl-output-debug-info file)) (dump-push res-handle file) - (dump-fop 'sb!impl::fop-structset file) + (dump-fop 'fop-structset file) (dump-unsigned-32 info-handle file) (dump-unsigned-32 2 file)))) - - (setf (fasl-file-debug-info file) ()) + (setf (fasl-output-debug-info file) nil) (values)) ;;;; dumping structures (defun dump-structure (struct file) (when *dump-only-valid-structures* - (unless (gethash struct (fasl-file-valid-structures file)) + (unless (gethash struct (fasl-output-valid-structures file)) (error "attempt to dump invalid structure:~% ~S~%How did this happen?" struct))) (note-potential-circularity struct file) (do ((index 0 (1+ index)) (length (%instance-length struct)) - (circ (fasl-file-circularity-table file))) + (circ (fasl-output-circularity-table file))) ((= index length) - (dump-fop* length - sb!impl::fop-small-struct - sb!impl::fop-struct - file)) + (dump-fop* length fop-small-struct fop-struct file)) (let* ((obj (%instance-ref struct index)) (ref (gethash obj circ))) (cond (ref @@ -1374,11 +1360,11 @@ (let ((name (sb!xc:class-name (layout-class obj)))) (unless name (compiler-error "dumping anonymous layout: ~S" obj)) - (dump-fop 'sb!impl::fop-normal-load file) + (dump-fop 'fop-normal-load file) (let ((*cold-load-dump* t)) (dump-object name file)) - (dump-fop 'sb!impl::fop-maybe-cold-load file)) + (dump-fop 'fop-maybe-cold-load file)) (sub-dump-object (layout-inherits obj) file) (sub-dump-object (layout-depthoid obj) file) (sub-dump-object (layout-length obj) file) - (dump-fop 'sb!impl::fop-layout file)) + (dump-fop 'fop-layout file)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index c50f246..a552178 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -30,7 +30,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!IMPL") +(in-package "SB!FASL") ;;; a magic number used to identify our core files (defconstant core-magic @@ -1140,11 +1140,11 @@ `(cold-set ',symbol (cold-fdefinition-object (cold-intern ',symbol))))) (frob !cold-init) - (frob sb!impl::maybe-gc) + (frob maybe-gc) (frob internal-error) (frob sb!di::handle-breakpoint) (frob sb!di::handle-function-end-breakpoint) - (frob sb!impl::fdefinition-object)) + (frob fdefinition-object)) (cold-set '*current-catch-block* (make-fixnum-descriptor 0)) (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0)) @@ -1152,9 +1152,7 @@ (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0)) - ;; FIXME: *!INITIAL-LAYOUTS* should be exported from SB!KERNEL, or - ;; perhaps from SB-LD. - (cold-set 'sb!kernel::*!initial-layouts* (cold-list-all-layouts)) + (cold-set '*!initial-layouts* (cold-list-all-layouts)) (/show "dumping packages" (mapcar #'car *cold-package-symbols*)) (let ((initial-symbols *nil-descriptor*)) @@ -1565,10 +1563,10 @@ offset-within-code-object)) (gspace-byte-address (gspace-byte-address (descriptor-gspace code-object)))) - (ecase sb!c:*backend-fasl-file-implementation* - ;; See CMUCL source for other formerly-supported architectures - ;; (and note that you have to rewrite them to use vector-ref unstead - ;; of sap-ref) + (ecase +backend-fasl-file-implementation+ + ;; See CMU CL source for other formerly-supported architectures + ;; (and note that you have to rewrite them to use VECTOR-REF + ;; unstead of SAP-REF). (:alpha (ecase kind (:jmp-hint @@ -1817,11 +1815,11 @@ ;;;; cold fops for loading symbols -;;; Load a symbol SIZE characters long from *FASL-FILE* and intern +;;; 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-file* string) + (read-string-as-bytes *fasl-input-stream* string) (cold-intern (intern string package) package))) (macrolet ((frob (name pname-len package-len) @@ -1847,7 +1845,7 @@ (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-string-as-bytes *fasl-file* name) + (read-string-as-bytes *fasl-input-stream* name) (let ((symbol (allocate-symbol name))) (push-fop-table symbol)))) @@ -1904,7 +1902,7 @@ (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-string-as-bytes *fasl-file* string) + (read-string-as-bytes *fasl-input-stream* string) (string-to-core string))) (clone-cold-fop (fop-vector) @@ -1940,7 +1938,7 @@ (ceiling (* len sizebits) sb!vm:byte-bits)))) (read-sequence-or-die (descriptor-bytes result) - *fasl-file* + *fasl-input-stream* :start start :end end) result)) @@ -1955,7 +1953,7 @@ (ash sb!vm:vector-data-offset sb!vm:word-shift))) (end (+ start (* len sb!vm:word-bytes)))) (read-sequence-or-die (descriptor-bytes result) - *fasl-file* + *fasl-input-stream* :start start :end end) result)) @@ -2023,9 +2021,9 @@ #!+long-float (define-cold-fop (fop-long-float) - (ecase sb!c:*backend-fasl-file-implementation* - (:x86 ; 80 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (ecase +backend-fasl-file-implementation+ + (:x86 ; (which has 80-bit long-float format) + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:long-float-size) sb!vm:long-float-type)) @@ -2041,7 +2039,7 @@ ;; SBCL. #+nil (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:long-float-size) sb!vm:long-float-type)) @@ -2058,9 +2056,9 @@ #!+long-float (define-cold-fop (fop-complex-long-float) - (ecase sb!c:*backend-fasl-file-implementation* - (:x86 ; 80 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (ecase +backend-fasl-file-implementation+ + (:x86 ; (which has 80-bit long-float format) + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:complex-long-float-size) sb!vm:complex-long-float-type)) @@ -2093,7 +2091,7 @@ ;; This was supported in CMU CL, but isn't currently supported in SBCL. #+nil (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits (1- sb!vm:complex-long-float-size) sb!vm:complex-long-float-type)) @@ -2163,7 +2161,7 @@ (make-descriptor 0 0 nil counter))) (defun finalize-load-time-value-noise () - (cold-set (cold-intern 'sb!impl::*!load-time-values*) + (cold-set (cold-intern '*!load-time-values*) (allocate-vector-object *dynamic* sb!vm:word-bits *load-time-value-counter* @@ -2272,7 +2270,7 @@ (ash header-n-words sb!vm:word-shift))) (end (+ start code-size))) (read-sequence-or-die (descriptor-bytes des) - *fasl-file* + *fasl-input-stream* :start start :end end) #!+sb-show @@ -2366,7 +2364,7 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-string-as-bytes *fasl-file* sym) + (read-string-as-bytes *fasl-input-stream* sym) (let ((offset (read-arg 4)) (value (lookup-foreign-symbol sym))) (do-cold-fixup code-object offset value kind)) @@ -2397,7 +2395,7 @@ (ash header-n-words sb!vm:word-shift))) (end (+ start length))) (read-sequence-or-die (descriptor-bytes des) - *fasl-file* + *fasl-input-stream* :start start :end end)) des)) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index 7cfa60d..b0e698f 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -1,5 +1,9 @@ ;;;; target-only code that knows how to load compiled code directly ;;;; into core +;;;; +;;;; FIXME: The filename here is confusing because "core" here means +;;;; "main memory", while elsewhere in the system it connotes a +;;;; ".core" file dumping the contents of main memory. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -45,15 +49,16 @@ (trace-table-bits (* trace-table-len tt-bits-per-entry)) (total-length (+ length (ceiling trace-table-bits sb!vm:byte-bits))) (box-num (- (length constants) sb!vm:code-trace-table-offset-slot)) - #!+x86 - (code-obj - ;; FIXME: What is this *ENABLE-DYNAMIC-SPACE-CODE* stuff? - (if (and (boundp sb!impl::*enable-dynamic-space-code*) - sb!impl::*enable-dynamic-space-code*) - (%primitive allocate-dynamic-code-object box-num total-length) - (%primitive allocate-code-object box-num total-length))) - #!-x86 (code-obj + ;; FIXME: In CMU CL the X86 behavior here depended on + ;; *ENABLE-DYNAMIC-SPACE-CODE*, but in SBCL we always use + ;; dynamic space code, so we could make + ;; ALLOCATE-DYNAMIC-CODE-OBJECT more parallel with + ;; ALLOCATE-CODE-OBJECT and remove this confusing + ;; read-macro conditionalization. + #!+x86 + (%primitive allocate-dynamic-code-object box-num total-length) + #!-x86 (%primitive allocate-code-object box-num total-length)) (fill-ptr (code-instructions code-obj))) (declare (type index box-num total-length)) @@ -98,7 +103,7 @@ (cdr const) object)) (:fdefinition (setf (code-header-ref code-obj index) - (sb!impl::fdefinition-object (cdr const) t)))))))))) + (fdefinition-object (cdr const) t)))))))))) (values)) (defun make-core-byte-component (segment length constants xeps object) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 307d762..6b36ad1 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -487,7 +487,7 @@ (values)) ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. If we are producing a fasl-file, make sure that + ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it ;; needs to be. (defun reference-constant (start cont value) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 3f7d8e5..90e02db 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -137,7 +137,7 @@ (pprint-logical-block (*error-output* nil :per-line-prefix "; ") (apply #'compiler-mumble foo)))) -(deftype object () '(or fasl-file core-object null)) +(deftype object () '(or fasl-output core-object null)) (defvar *compile-object* nil) (declaim (type object *compile-object*)) @@ -461,7 +461,7 @@ *compiler-trace-output*)) (etypecase *compile-object* - (fasl-file + (fasl-output (maybe-mumble "fasl") (fasl-dump-component component *code-segment* @@ -972,7 +972,7 @@ (defun process-cold-load-form (form path eval) (let ((object *compile-object*)) (etypecase object - (fasl-file + (fasl-output (compile-top-level-lambdas () t) (fasl-dump-cold-load-form form object)) ((or null core-object) @@ -1048,11 +1048,11 @@ ;;;; ;;;; (See EMIT-MAKE-LOAD-FORM.) -;;; Returns T iff we are currently producing a fasl-file and hence +;;; Returns T iff we are currently producing a fasl file and hence ;;; constants need to be dumped carefully. (defun producing-fasl-file () (unless *converting-for-interpreter* - (fasl-file-p *compile-object*))) + (fasl-output-p *compile-object*))) ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. @@ -1101,125 +1101,6 @@ (setf (component-name component) (leaf-name lambda)) (compile-component component) (clear-ir1-info component)))) - -;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion -;;; finds a constant structure, it invokes this to arrange for proper -;;; dumping. If it turns out that the constant has already been -;;; dumped, then we don't need to do anything. -;;; -;;; If the constant hasn't been dumped, then we check to see whether -;;; we are in the process of creating it. We detect this by -;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all -;;; the constants we are in the process of creating. Actually, each -;;; entry is a list of the constant and any init forms that need to be -;;; processed on behalf of that constant. -;;; -;;; It's not necessarily an error for this to happen. If we are -;;; processing the init form for some object that showed up *after* -;;; the original reference to this constant, then we just need to -;;; defer the processing of that init form. To detect this, we -;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the -;;; constants created since the last time we started processing an -;;; init form. If the constant passed to emit-make-load-form shows up -;;; in this list, then there is a circular chain through creation -;;; forms, which is an error. -;;; -;;; If there is some intervening init form, then we blow out of -;;; processing it by throwing to the tag PENDING-INIT. The value we -;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the -;;; offending init form can be tacked onto the init forms for the -;;; circular object. -;;; -;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then -;;; we have to create it. We call MAKE-LOAD-FORM and check to see -;;; whether the creation form is the magic value -;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The -;;; dumper will eventually get its hands on the object and use the -;;; normal structure dumping noise on it. -;;; -;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and -;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form -;;; much the way LOAD-TIME-VALUE does. When this finishes, we tell the -;;; dumper to use that result instead whenever it sees this constant. -;;; -;;; Now we try to compile the init form. We bind -;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* to NIL and compile the init -;;; form (and any init forms that were added because of circularity -;;; detection). If this works, great. If not, we add the init forms to -;;; the init forms for the object that caused the problems and let it -;;; deal with it. -(defvar *constants-being-created* nil) -(defvar *constants-created-since-last-init* nil) -;;; FIXME: Shouldn't these^ variables be bound in LET forms? -(defun emit-make-load-form (constant) - (aver (fasl-file-p *compile-object*)) - (unless (or (fasl-constant-already-dumped constant *compile-object*) - ;; KLUDGE: This special hack is because I was too lazy - ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM - ;; function of LAYOUT returns nontrivial forms when - ;; building the cross-compiler but :IGNORE-IT when - ;; cross-compiling or running under the target Lisp. -- - ;; WHN 19990914 - #+sb-xc-host (typep constant 'layout)) - (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) - (when circular-ref - (when (find constant *constants-created-since-last-init* :test #'eq) - (throw constant t)) - (throw 'pending-init circular-ref))) - (multiple-value-bind (creation-form init-form) - (handler-case - (sb!xc:make-load-form constant (make-null-lexenv)) - (error (condition) - (compiler-error "(while making load form for ~S)~%~A" - constant - condition))) - (case creation-form - (:just-dump-it-normally - (fasl-validate-structure constant *compile-object*) - t) - (:ignore-it - nil) - (t - (compile-top-level-lambdas () t) - (when (fasl-constant-already-dumped constant *compile-object*) - (return-from emit-make-load-form nil)) - (let* ((name (let ((*print-level* 1) (*print-length* 2)) - (with-output-to-string (stream) - (write constant :stream stream)))) - (info (if init-form - (list constant name init-form) - (list constant)))) - (let ((*constants-being-created* - (cons info *constants-being-created*)) - (*constants-created-since-last-init* - (cons constant *constants-created-since-last-init*))) - (when - (catch constant - (fasl-note-handle-for-constant - constant - (compile-load-time-value - creation-form - (format nil "creation form for ~A" name)) - *compile-object*) - nil) - (compiler-error "circular references in creation form for ~S" - constant))) - (when (cdr info) - (let* ((*constants-created-since-last-init* nil) - (circular-ref - (catch 'pending-init - (loop for (name form) on (cdr info) by #'cddr - collect name into names - collect form into forms - finally - (compile-make-load-form-init-forms - forms - (format nil "init form~:[~;s~] for ~{~A~^, ~}" - (cdr forms) names))) - nil))) - (when circular-ref - (setf (cdr circular-ref) - (append (cdr circular-ref) (cdr info)))))))))))) ;;;; COMPILE-FILE @@ -1256,7 +1137,7 @@ (declare (type functional tll)) (let ((object *compile-object*)) (etypecase object - (fasl-file + (fasl-output (fasl-dump-top-level-lambda-call tll object)) (core-object (core-call-top-level-lambda tll object)) @@ -1419,7 +1300,7 @@ (compile-top-level-lambdas () t) (let ((object *compile-object*)) (etypecase object - (fasl-file (fasl-dump-source-info info object)) + (fasl-output (fasl-dump-source-info info object)) (core-object (fix-core-source-info info object d-s-info)) (null))) nil)))) @@ -1528,7 +1409,7 @@ (unless (eq external-format :default) (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported.")) - (let* ((fasl-file nil) + (let* ((fasl-output nil) (output-file-name nil) (compile-won nil) (warnings-p nil) @@ -1550,10 +1431,10 @@ (setq output-file-name (sb!xc:compile-file-pathname input-file :output-file output-file)) - (setq fasl-file - (open-fasl-file output-file-name - (namestring input-pathname) - (eq *byte-compile* t)))) + (setq fasl-output + (open-fasl-output output-file-name + (namestring input-pathname) + (eq *byte-compile* t)))) (when trace-file (let* ((default-trace-file-pathname (make-pathname :type "trace" :defaults input-pathname)) @@ -1569,7 +1450,7 @@ (when sb!xc:*compile-verbose* (start-error-output source-info)) - (let ((*compile-object* fasl-file) + (let ((*compile-object* fasl-output) dummy) (multiple-value-setq (dummy warnings-p failure-p) (sub-compile-file source-info))) @@ -1577,9 +1458,10 @@ (close-source-info source-info) - (when fasl-file - (close-fasl-file fasl-file (not compile-won)) - (setq output-file-name (pathname (fasl-file-stream fasl-file))) + (when fasl-output + (close-fasl-output fasl-output (not compile-won)) + (setq output-file-name + (pathname (fasl-output-stream fasl-output))) (when (and compile-won sb!xc:*compile-verbose*) (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) @@ -1605,18 +1487,7 @@ ;;; default to the appropriate implementation-defined default type for ;;; compiled files. (defun cfp-output-file-default (input-file) - (let* (;; FIXME: I think the PHYSICALIZE-PATHNAME wrapper here - ;; shouldn't really be necessary. Unfortunately - ;; sbcl-0.6.12.18's MERGE-PATHNAMES doesn't like logical - ;; pathnames very much, and doesn't get good results in - ;; tests/side-effectful-pathnames.sh for (COMPILE-FILE - ;; "TEST:$StudlyCapsStem"), unless I do this. It would be - ;; good to straighten out how MERGE-PATHNAMES is really - ;; supposed to work for logical pathnames, and add a bunch of - ;; test cases to check it, then get rid of this cruft. - (defaults (merge-pathnames (physicalize-pathname (pathname - input-file)) - *default-pathname-defaults*)) + (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*)) (retyped (make-pathname :type *backend-fasl-file-type* :defaults defaults))) retyped)) @@ -1639,3 +1510,124 @@ "Return a pathname describing what file COMPILE-FILE would write to given these arguments." (pathname output-file)) + +;;;; MAKE-LOAD-FORM stuff + +;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion +;;; finds a constant structure, it invokes this to arrange for proper +;;; dumping. If it turns out that the constant has already been +;;; dumped, then we don't need to do anything. +;;; +;;; If the constant hasn't been dumped, then we check to see whether +;;; we are in the process of creating it. We detect this by +;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all +;;; the constants we are in the process of creating. Actually, each +;;; entry is a list of the constant and any init forms that need to be +;;; processed on behalf of that constant. +;;; +;;; It's not necessarily an error for this to happen. If we are +;;; processing the init form for some object that showed up *after* +;;; the original reference to this constant, then we just need to +;;; defer the processing of that init form. To detect this, we +;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the +;;; constants created since the last time we started processing an +;;; init form. If the constant passed to emit-make-load-form shows up +;;; in this list, then there is a circular chain through creation +;;; forms, which is an error. +;;; +;;; If there is some intervening init form, then we blow out of +;;; processing it by throwing to the tag PENDING-INIT. The value we +;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the +;;; offending init form can be tacked onto the init forms for the +;;; circular object. +;;; +;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then +;;; we have to create it. We call MAKE-LOAD-FORM and check to see +;;; whether the creation form is the magic value +;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The +;;; dumper will eventually get its hands on the object and use the +;;; normal structure dumping noise on it. +;;; +;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and +;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form +;;; much the way LOAD-TIME-VALUE does. When this finishes, we tell the +;;; dumper to use that result instead whenever it sees this constant. +;;; +;;; Now we try to compile the init form. We bind +;;; *CONSTANTS-CREATED-SINCE-LAST-INIT* to NIL and compile the init +;;; form (and any init forms that were added because of circularity +;;; detection). If this works, great. If not, we add the init forms to +;;; the init forms for the object that caused the problems and let it +;;; deal with it. +(defvar *constants-being-created* nil) +(defvar *constants-created-since-last-init* nil) +;;; FIXME: Shouldn't these^ variables be bound in LET forms? +(defun emit-make-load-form (constant) + (aver (fasl-output-p *compile-object*)) + (unless (or (fasl-constant-already-dumped-p constant *compile-object*) + ;; KLUDGE: This special hack is because I was too lazy + ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM + ;; function of LAYOUT returns nontrivial forms when + ;; building the cross-compiler but :IGNORE-IT when + ;; cross-compiling or running under the target Lisp. -- + ;; WHN 19990914 + #+sb-xc-host (typep constant 'layout)) + (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) + (when circular-ref + (when (find constant *constants-created-since-last-init* :test #'eq) + (throw constant t)) + (throw 'pending-init circular-ref))) + (multiple-value-bind (creation-form init-form) + (handler-case + (sb!xc:make-load-form constant (make-null-lexenv)) + (error (condition) + (compiler-error "(while making load form for ~S)~%~A" + constant + condition))) + (case creation-form + (:just-dump-it-normally + (fasl-validate-structure constant *compile-object*) + t) + (:ignore-it + nil) + (t + (compile-top-level-lambdas () t) + (when (fasl-constant-already-dumped-p constant *compile-object*) + (return-from emit-make-load-form nil)) + (let* ((name (let ((*print-level* 1) (*print-length* 2)) + (with-output-to-string (stream) + (write constant :stream stream)))) + (info (if init-form + (list constant name init-form) + (list constant)))) + (let ((*constants-being-created* + (cons info *constants-being-created*)) + (*constants-created-since-last-init* + (cons constant *constants-created-since-last-init*))) + (when + (catch constant + (fasl-note-handle-for-constant + constant + (compile-load-time-value + creation-form + (format nil "creation form for ~A" name)) + *compile-object*) + nil) + (compiler-error "circular references in creation form for ~S" + constant))) + (when (cdr info) + (let* ((*constants-created-since-last-init* nil) + (circular-ref + (catch 'pending-init + (loop for (name form) on (cdr info) by #'cddr + collect name into names + collect form into forms + finally + (compile-make-load-form-init-forms + forms + (format nil "init form~:[~;s~] for ~{~A~^, ~}" + (cdr forms) names))) + nil))) + (when circular-ref + (setf (cdr circular-ref) + (append (cdr circular-ref) (cdr info)))))))))))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index b227008..8f30618 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1825,9 +1825,9 @@ (declare (type address address)) (when (null *assembler-routines-by-addr*) (setf *assembler-routines-by-addr* - (invert-address-hash sb!kernel::*assembler-routines*)) + (invert-address-hash sb!fasl:*assembler-routines*)) (setf *assembler-routines-by-addr* - (invert-address-hash sb!kernel::*static-foreign-symbols* + (invert-address-hash sb!fasl:*static-foreign-symbols* *assembler-routines-by-addr*))) (gethash address *assembler-routines-by-addr*)) diff --git a/src/compiler/target-dump.lisp b/src/compiler/target-dump.lisp index 5f61b34..0c9d4d3 100644 --- a/src/compiler/target-dump.lisp +++ b/src/compiler/target-dump.lisp @@ -11,69 +11,72 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!C") +(in-package "SB!FASL") ;;; Dump the first N bytes of VEC out to FILE. VEC is some sort of unboxed ;;; vector-like thing that we can BLT from. -(defun dump-raw-bytes (vec n fasl-file) - (declare (type index n) (type fasl-file fasl-file)) - (sb!sys:output-raw-bytes (fasl-file-stream fasl-file) vec 0 n) +(defun dump-raw-bytes (vec n fasl-output) + (declare (type index n) (type fasl-output fasl-output)) + (sb!sys:output-raw-bytes (fasl-output-stream fasl-output) vec 0 n) (values)) ;;; Dump a multi-dimensional array. Note: any displacements are folded out. ;;; ;;; This isn't needed at cross-compilation time because SBCL doesn't -;;; use multi-dimensional arrays internally. It's hard to implement -;;; at cross-compilation time because it uses WITH-ARRAY-DATA. If it ever -;;; becomes necessary to implement it at cross-compilation time, it might -;;; possible to use ROW-MAJOR-AREF stuff to do it portably. +;;; use multi-dimensional arrays internally. And it's hard to +;;; implement at cross-compilation time because it uses +;;; WITH-ARRAY-DATA. If it ever becomes necessary to implement it at +;;; cross-compilation time, it might possible to use ROW-MAJOR-AREF +;;; stuff to do it portably. (defun dump-multi-dim-array (array file) (let ((rank (array-rank array))) (dotimes (i rank) (dump-integer (array-dimension array i) file)) - (sb!impl::with-array-data ((vector array) (start) (end)) + (with-array-data ((vector array) (start) (end)) (if (and (= start 0) (= end (length vector))) (sub-dump-object vector file) (sub-dump-object (subseq vector start end) file))) - (dump-fop 'sb!impl::fop-array file) + (dump-fop 'fop-array file) (dump-unsigned-32 rank file) (eq-save-object array file))) +;;;; various dump-a-number operations + (defun dump-single-float-vector (vec file) (let ((length (length vec))) - (dump-fop 'sb!impl::fop-single-float-vector file) + (dump-fop 'fop-single-float-vector file) (dump-unsigned-32 length file) (dump-raw-bytes vec (* length sb!vm:word-bytes) file))) (defun dump-double-float-vector (vec file) (let ((length (length vec))) - (dump-fop 'sb!impl::fop-double-float-vector file) + (dump-fop 'fop-double-float-vector file) (dump-unsigned-32 length file) (dump-raw-bytes vec (* length sb!vm:word-bytes 2) file))) #!+long-float (defun dump-long-float-vector (vec file) (let ((length (length vec))) - (dump-fop 'sb!impl::fop-long-float-vector file) + (dump-fop 'fop-long-float-vector file) (dump-unsigned-32 length file) (dump-raw-bytes vec (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4) file))) (defun dump-complex-single-float-vector (vec file) (let ((length (length vec))) - (dump-fop 'sb!impl::fop-complex-single-float-vector file) + (dump-fop 'fop-complex-single-float-vector file) (dump-unsigned-32 length file) (dump-raw-bytes vec (* length sb!vm:word-bytes 2) file))) (defun dump-complex-double-float-vector (vec file) (let ((length (length vec))) - (dump-fop 'sb!impl::fop-complex-double-float-vector file) + (dump-fop 'fop-complex-double-float-vector file) (dump-unsigned-32 length file) (dump-raw-bytes vec (* length sb!vm:word-bytes 2 2) file))) #!+long-float (defun dump-complex-long-float-vector (vec file) (let ((length (length vec))) - (dump-fop 'sb!impl::fop-complex-long-float-vector file) + (dump-fop 'fop-complex-long-float-vector file) (dump-unsigned-32 length file) (dump-raw-bytes vec (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2) file))) @@ -99,16 +102,14 @@ (dump-unsigned-32 high-bits file) (dump-integer-as-n-bytes exp-bits 4 file))) -;;; Or a complex... - (defun dump-complex (x file) (typecase x ((complex single-float) - (dump-fop 'sb!impl::fop-complex-single-float file) + (dump-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 'sb!impl::fop-complex-double-float file) + (dump-fop 'fop-complex-double-float file) (let ((re (realpart x))) (declare (double-float re)) (dump-unsigned-32 (double-float-low-bits re) file) @@ -119,11 +120,28 @@ (dump-integer-as-n-bytes (double-float-high-bits im) 4 file))) #!+long-float ((complex long-float) - (dump-fop 'sb!impl::fop-complex-long-float file) + (dump-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 'sb!impl::fop-complex file)))) + (dump-fop 'fop-complex file)))) + +;;;; dumping things which don't exist in portable ANSI Common Lisp +;;; Dump a BYTE-FUNCTION object. We dump the layout and +;;; funcallable-instance info, but rely on the loader setting up the +;;; correct funcallable-instance-function. +(defun dump-byte-function (xep code-handle file) + (let ((nslots (- (get-closure-length xep) + ;; 1- for header + (1- sb!vm:funcallable-instance-info-offset)))) + (dotimes (i nslots) + (if (zerop i) + (dump-push code-handle file) + (dump-object (%funcallable-instance-info xep i) file))) + (dump-object (%funcallable-instance-layout xep) file) + (dump-fop 'fop-make-byte-compiled-function file) + (dump-byte nslots file)) + (values)) diff --git a/src/compiler/x86/backend-parms.lisp b/src/compiler/x86/backend-parms.lisp index 057a09c..be2a8f4 100644 --- a/src/compiler/x86/backend-parms.lisp +++ b/src/compiler/x86/backend-parms.lisp @@ -18,31 +18,7 @@ ;;;; compiler constants (setf *backend-fasl-file-type* "x86f") -(setf *backend-fasl-file-implementation* :x86) - -(setf *backend-fasl-file-version* 11) -;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC. -;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot. -;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET -;;; when array headers or data element type uncertainty exist, and -;;; uses DATA-VECTOR-REF and DATA-VECTOR-SET only for VOPs. (Thus, -;;; full calls to DATA-VECTOR-REF and DATA-VECTOR-SET from older -;;; fasl files would fail, because there are no DEFUNs for these -;;; operations any more.) -;;; 5 = sbcl-0.6.8 has rearranged static symbols. -;;; 6 = sbcl-0.6.9, got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff -;;; and deleted a slot from DEBUG-SOURCE structure. -;;; 7 = around sbcl-0.6.9.8, merged SB-CONDITIONS package into SB-KERNEL -;;; 8 = sbcl-0.6.10.4 revived Gray stream support, changing stream layouts. -;;; 9 = deleted obsolete CONS-UNIQUE-TAG bytecode in sbcl-0.6.11.8 -;;; (somewhere in here also changes to AND and OR CTYPE layouts) -;;; 10 = new layout for CONDITION in sbcl-0.6.11.38 -;;; 11 = (a) new helper functions for MAKE-LOAD-FORM (HASH-TABLE) in -;;; sbcl-0.6.12.11 -;;; (b) new address space constants for OpenBSD in 0.6.12.17, -;;; doesn't need separate version from (a) because the OpenBSD -;;; port was broken from sometime before 0.6.12.11 until -;;; the address space was changed +(defconstant +backend-fasl-file-implementation+ :x86) (setf *backend-register-save-penalty* 3) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 66f1d11..b82ca88 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -367,9 +367,6 @@ ;;; something to compile with :SB-NO-PSEUDO-ATOMIC. (defvar *enable-pseudo-atomic* t) -;;; FIXME: *PSEUDO-ATOMIC-ATOMIC* and *PSEUDO-ATOMIC-INTERRUPTED* -;;; should be in package SB!VM or SB!KERNEL, not SB!IMPL. - ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*, ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2; ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check @@ -385,7 +382,7 @@ ;; something. (perhaps SVLB, for static variable low byte) (inst mov (make-ea :byte :disp (+ nil-value (static-symbol-offset - 'sb!impl::*pseudo-atomic-interrupted*) + '*pseudo-atomic-interrupted*) (ash symbol-value-slot word-shift) ;; FIXME: Use mask, not minus, to ;; take out type bits. @@ -393,7 +390,7 @@ 0) (inst mov (make-ea :byte :disp (+ nil-value (static-symbol-offset - 'sb!impl::*pseudo-atomic-atomic*) + '*pseudo-atomic-atomic*) (ash symbol-value-slot word-shift) (- other-pointer-type))) (fixnumize 1))) @@ -401,7 +398,7 @@ (when *enable-pseudo-atomic* (inst mov (make-ea :byte :disp (+ nil-value (static-symbol-offset - 'sb!impl::*pseudo-atomic-atomic*) + '*pseudo-atomic-atomic*) (ash symbol-value-slot word-shift) (- other-pointer-type))) 0) @@ -414,7 +411,7 @@ (inst cmp (make-ea :byte :disp (+ nil-value (static-symbol-offset - 'sb!impl::*pseudo-atomic-interrupted*) + '*pseudo-atomic-interrupted*) (ash symbol-value-slot word-shift) (- other-pointer-type))) 0) diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index b098811..a0030d4 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -49,8 +49,8 @@ (eval :scs (descriptor-reg)) (alien-stack :scs (descriptor-reg))) (:generator 13 - (load-symbol-value catch sb!impl::*current-catch-block*) - (load-symbol-value eval sb!impl::*eval-stack-top*) + (load-symbol-value catch *current-catch-block*) + (load-symbol-value eval *eval-stack-top*) (load-symbol-value alien-stack *alien-stack*))) (define-vop (restore-dynamic-state) @@ -58,8 +58,8 @@ (eval :scs (descriptor-reg)) (alien-stack :scs (descriptor-reg))) (:generator 10 - (store-symbol-value catch sb!impl::*current-catch-block*) - (store-symbol-value eval sb!impl::*eval-stack-top*) + (store-symbol-value catch *current-catch-block*) + (store-symbol-value eval *eval-stack-top*) (store-symbol-value alien-stack *alien-stack*))) (define-vop (current-stack-pointer) @@ -83,7 +83,7 @@ (:results (block :scs (any-reg))) (:generator 22 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp sb!impl::*current-unwind-protect-block*) + (load-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) @@ -99,15 +99,15 @@ (:temporary (:sc descriptor-reg) temp) (:generator 44 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp sb!impl::*current-unwind-protect-block*) + (load-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) block catch-block-entry-pc-slot) (storew tag block catch-block-tag-slot) - (load-symbol-value temp sb!impl::*current-catch-block*) + (load-symbol-value temp *current-catch-block*) (storew temp block catch-block-previous-catch-slot) - (store-symbol-value block sb!impl::*current-catch-block*))) + (store-symbol-value block *current-catch-block*))) ;;; Just set the current unwind-protect to TN's address. This instantiates an ;;; unwind block as an unwind-protect. @@ -116,25 +116,25 @@ (:temporary (:sc unsigned-reg) new-uwp) (:generator 7 (inst lea new-uwp (catch-block-ea tn)) - (store-symbol-value new-uwp sb!impl::*current-unwind-protect-block*))) + (store-symbol-value new-uwp *current-unwind-protect-block*))) (define-vop (unlink-catch-block) (:temporary (:sc unsigned-reg) block) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 - (load-symbol-value block sb!impl::*current-catch-block*) + (load-symbol-value block *current-catch-block*) (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block sb!impl::*current-catch-block*))) + (store-symbol-value block *current-catch-block*))) (define-vop (unlink-unwind-protect) (:temporary (:sc unsigned-reg) block) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 - (load-symbol-value block sb!impl::*current-unwind-protect-block*) + (load-symbol-value block *current-unwind-protect-block*) (loadw block block unwind-block-current-uwp-slot) - (store-symbol-value block sb!impl::*current-unwind-protect-block*))) + (store-symbol-value block *current-unwind-protect-block*))) ;;;; NLX entry VOPs (define-vop (nlx-entry) diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 8bbe40c..2a5a9b8 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -239,10 +239,10 @@ ;; functions that the C code needs to call sb!impl::!cold-init - sb!impl::maybe-gc + maybe-gc sb!kernel::internal-error sb!di::handle-breakpoint - sb!impl::fdefinition-object + fdefinition-object ;; free pointers ;; @@ -255,17 +255,17 @@ *initial-dynamic-space-free-pointer* ;; things needed for non-local exit - sb!impl::*current-catch-block* - sb!impl::*current-unwind-protect-block* - sb!c::*eval-stack-top* + *current-catch-block* + *current-unwind-protect-block* + *eval-stack-top* sb!vm::*alien-stack* ;; interrupt handling - sb!impl::*pseudo-atomic-atomic* - sb!impl::*pseudo-atomic-interrupted* + *pseudo-atomic-atomic* + *pseudo-atomic-interrupted* sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending* - sb!impl::*free-interrupt-context-index* + *free-interrupt-context-index* sb!vm::*allocation-pointer* sb!vm::*binding-stack-pointer* diff --git a/src/runtime/gc.c b/src/runtime/gc.c index b944ef1..0cb2f37 100644 --- a/src/runtime/gc.c +++ b/src/runtime/gc.c @@ -565,15 +565,15 @@ scavenge_interrupt_context(os_context_t *context) void scavenge_interrupt_contexts(void) { - int i, index; - os_context_t *context; + int i, index; + os_context_t *context; - index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)); + index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)); - for (i = 0; i < index; i++) { - context = lisp_interrupt_contexts[i]; - scavenge_interrupt_context(context); - } + for (i = 0; i < index; i++) { + context = lisp_interrupt_contexts[i]; + scavenge_interrupt_context(context); + } } diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index c497859..a3a4d21 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -97,7 +97,7 @@ ("src/code/specializable-array") ("src/code/early-cl") - ("src/code/early-load") + ("src/code/early-fasl") ;; mostly needed by stuff from comcom, but also used by "x86-vm" ("src/code/debug-var-io") @@ -429,11 +429,11 @@ ("src/compiler/trace-table") ; needs EMIT-LABEL macro from compiler/assem.lisp - ;; Compiling this file requires fop definitions from code/fop.lisp - ;; and trace table definitions from compiler/trace-table.lisp. + ;; Compiling this requires fop definitions from code/fop.lisp and + ;; trace table definitions from compiler/trace-table.lisp. ("src/compiler/dump") - ("src/compiler/main") ; needs DEFSTRUCT FASL-FILE from compiler/dump.lisp + ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp ("src/compiler/target-main" :not-host) ("src/compiler/ir1tran") ("src/compiler/ir1util") @@ -542,7 +542,7 @@ #!+sb-dyncount ("src/compiler/dyncount") #!+sb-dyncount ("src/code/dyncount") - ;; needed by OPEN-FASL-FILE, which is called by COMPILE-FILE + ;; needed by OPEN-FASL-OUTPUT, which is called by COMPILE-FILE ("src/code/format-time") ;; needed by various unhappy-path cases in the cross-compiler diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index e0672a8..3ef66b6 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -33,3 +33,4 @@ (when (find-package public-package) (check-ext-symbols-arglist public-package))) (terpri) +(print "done with interface.pure.lisp") diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index d462c1b..6682f8c 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -159,5 +159,95 @@ "test0:foo;bar;baz;mum.quux.3")) "/library/foo/foo/bar/baz/mum.quux")) -;;; success +;;;; MERGE-PATHNAME tests +;;;; +;;;; There are some things we don't bother testing, just because they're +;;;; not meaningful on the underlying filesystem anyway. +;;;; +;;;; Mostly that means that we don't do devices, we don't do versions +;;;; except minimally in LPNs (they get lost in the translation to +;;;; physical hosts, so it's not much of an issue), and we don't do +;;;; hosts except for LPN hosts +;;;; +;;;; Although these tests could conceivably be useful in principle for +;;;; other implementations, they depend quite heavily on the rules for +;;;; namestring parsing, which are implementation-specific. So, success +;;;; or failure in these tests doesn't tell you anything about +;;;; ansi-compliance unless your PARSE-NAMESTRING works like ours. + +(setf (logical-pathname-translations "scratch") + '(("**;*.*.*" "/usr/local/doc/**/*"))) + +(loop for (expected-result . params) in + `(;; trivial merge + (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/") + ;; If pathname does not specify a host, device, directory, + ;; name, or type, each such component is copied from + ;; default-pathname. + ;; 1) no name, no type + (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type") + ;; 2) no directory, no type + (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type") + ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed + ;; as a name) + (#p"/dir/name.supplied-type" + ,(make-pathname :type "supplied-type") + #p"/dir/name.type") + ;; If (pathname-directory pathname) is a list whose car is + ;; :relative, and (pathname-directory default-pathname) is a + ;; list, then the merged directory is [...] + (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee") + ;; except that if the resulting list contains a string or + ;; :wild immediately followed by :back, both of them are + ;; removed. + (#P"/aaa/bbb/ccc/blah/eee" + ;; "../" in a namestring is parsed as :up not :back, so make-pathname + ,(make-pathname :directory '(:relative :back "blah")) + #p"/aaa/bbb/ccc/ddd/eee") + ;; If (pathname-directory default-pathname) is not a list or + ;; (pathname-directory pathname) is not a list whose car is + ;; :relative, the merged directory is (or (pathname-directory + ;; pathname) (pathname-directory default-pathname)) + (#P"/absolute/path/name.type" + #p"/absolute/path/name" + #p"/dir/default-name.type") + ;; === logical pathnames === + ;; recognizes a logical pathname namestring when + ;; default-pathname is a logical pathname + ;; FIXME: 0.6.12.20 fails this one. + #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;") + ;; or when the namestring begins with the name of a defined + ;; logical host followed by a colon [I assume that refers to pathname + ;; rather than default-pathname] + (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;") + ;; conduct the previous set of tests again, with a lpn first argument + (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/") + (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE" + #p"scratch:supplied-dir;" + #p"/dir/name.type") + (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE" + #p"scratch:;supplied-name" + #p"/dir/name.type") + (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE" + ,(make-pathname :host "scratch" :type "supplied-type") + #p"/dir/name.type") + (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" + ,(make-pathname :host "scratch" + :directory '(:relative "foo") + :name "bar") + #p"/aaa/bbb/ccc/ddd/eee") + (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR" + ,(make-pathname :host "scratch" + :directory '(:relative :back "foo") + :name "bar") + #p"/aaa/bbb/ccc/ddd/eee") + (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" + #p"scratch:absolute;path;name" #p"/dir/default-name.type") + + ;; TODO: test version handling in LPNs + ) + do (assert (string= (namestring (apply #'merge-pathnames params)) + (namestring expected-result)))) + +;;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 2e6b066..bce2327 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.12.21" +"0.6.12.22"