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 #<PACKAGE "SB-ALIEN">.
+ Macro-function: #<FUNCTION "DEF!MACRO DEF-ALIEN-TYPE" {19F4A39}>
+ 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
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
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.
(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)
;; 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")
)
#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*"
;; 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*"
"*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*"
"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"
"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"
"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
: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"
#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"
"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*"
;; 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"
;; 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"
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"
"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"
"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"
"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"
"!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
"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"
: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"
#!-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"
;; 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)
;; 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)))
\f
(: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)
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
(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
(in-package "SB!C")
\f
-(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
;; 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)
(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*)))
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))
(declare (ignore start count))
- (load-symbol-value catch sb!impl::*current-catch-block*)
+ (load-symbol-value catch *current-catch-block*)
LOOP
(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
;; 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
(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)
(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
(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))
\f
;; 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)))
\f
;;;; some support for any hapless wretches who end up debugging cold
;;;; 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
;;;;
#!+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))
#!-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)))
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))))
;;; 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*
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*
;;; 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
(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))))))))
;;;; 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:
(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*)
(* ,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
(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)
\f
;;;; 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)
(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))))
(%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))
#!+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))
(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))
#!+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))
(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)
(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))
(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))
;;; 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
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))
;;; 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
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)
(format t "~S defined~%" res))
res))
\f
-;;;; Some Dylan fops used to live here. By 1 November 1998 the code was
-;;;; sufficiently stale that the functions it called were no longer defined,
-;;;; so I (William Harold Newman) deleted it.
+;;;; 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
(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)
(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)
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!IMPL")
-\f
-;;;; variables
-
-;;; FIXME: It's awkward having LOAD stuff in SB!IMPL and dump stuff in
-;;; SB!C. Among other things, it makes it hard to figure out where
-;;; *FASL-HEADER-STRING-START-STRING* and
-;;; *FASL-HEADER-STRING-STOP-CHAR-CODE* should go. Perhaps we should
-;;; make a package called SB-DUMP or SB-LD which includes all
-;;; knowledge of both loading and dumping.
-
-;;; This value is used to identify fasl files. Even though this is not
-;;; declared as a constant (because ANSI Common Lisp has no facility
-;;; for declaring values which are constant under EQUAL but not EQL),
-;;; obviously you shouldn't mess with it lightly. If you do set a new
-;;; value for some reason, keep these things in mind:
-;;; * To avoid confusion with the similar but incompatible CMU CL
-;;; fasl file format, the value should not be "FASL FILE", which
-;;; is what CMU CL used for the same purpose.
-;;; * Since its presence at the head of a file is used by LOAD to
-;;; decide whether a file is to be fasloaded or 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")
\f
;;;; miscellaneous load utilities
(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)))))
(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)
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.
(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*))
(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)
(without-gcing
(save (unix-namestring core-file-name nil)
(get-lisp-obj-address #'restart-lisp)))))
-\f
-;;;; functions used by worldload.lisp in CMU CL bootstrapping
-
-;;; If NAME has been byte-compiled, and :RUNTIME is a feature, then
-;;; load the byte-compiled version, otherwise just do normal load.
-#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
-(defun maybe-byte-load (name &optional (load-native t))
- (let ((bname (make-pathname
- :defaults name
- :type #.(sb!c:backend-byte-fasl-file-type))))
- (cond ((and (featurep :runtime)
- (probe-file bname))
- (load bname))
- (load-native
- (load name)))))
-
-;;; Replace a cold-loaded native object file with a byte-compiled one, if it
-;;; exists.
-#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
-(defun byte-load-over (name)
- (load (make-pathname
- :defaults name
- :type #.(sb!c:backend-byte-fasl-file-type))
- :if-does-not-exist nil))
;;;; 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*))
\f
;;;; LOAD-AS-SOURCE
(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
(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
(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))
(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))
(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)))))
\f
;;;; linkage fixups
: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)
\f
(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")
\f
;;;; 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*)
(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)))
;;;; 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)
(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))
(: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
(: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)
(: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)
(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)))
(: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*)))
\f
;;;; NLX entry VOPs
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*
*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*))
\f
;;;; miscellaneous backend properties
-;;; the conventional file extension for fasl files on this architecture,
-;;; e.g. "x86f"
-(defvar *backend-fasl-file-type* nil)
-(declaim (type (or simple-string null) *backend-fasl-file-type*))
-
-;;; implementation and version of fasl files used
-(defvar *backend-fasl-file-implementation* nil)
-(defvar *backend-fasl-file-version* nil)
-(declaim (type (or keyword null) *backend-fasl-file-implementation*))
-(declaim (type (or index null) *backend-fasl-file-version*))
-
-;;; the number of references that a TN must have to offset the overhead of
-;;; saving the TN across a call
+;;; the number of references that a TN must have to offset the
+;;; overhead of saving the TN across a call
(defvar *backend-register-save-penalty* 0)
(declaim (type index *backend-register-save-penalty*))
;;; the VM support routines
(defvar *backend-support-routines* (make-vm-support-routines))
(declaim (type vm-support-routines *backend-support-routines*))
-\f
-;;;; utilities
-
-(defun backend-byte-fasl-file-implementation ()
- *backend-byte-order*)
(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.
(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*))
;;;; 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
\f
;;;; fasl dumper state
-;;; The FASL-FILE structure represents everything we need to know
-;;; about dumping to a fasl file. We need to objectify the state,
-;;; since the fasdumper must be reentrant.
-(defstruct (fasl-file
+;;; 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)
(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))))
;;; 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
#!+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
;;; 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))))
(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)))))
;;; 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
;;; 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))
;;; 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))
\f
;;;; opening and closing fasl files
-;;; Open a fasl file, write its header, and return a FASL-FILE object
-;;; for dumping to it. Some human-readable information about the
-;;; source code is given by the string WHERE. If BYTE-P is true, this
-;;; file will contain no native code, and is thus largely
+;;; 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
(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))
\f
;;;; main entries to object dumping
;;;
;;; 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
(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))
;;; 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)
(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
(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*
;;; 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))
;;; 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))
\f
;;;; number dumping
(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
(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)
(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))))
\f
;;;; symbol dumping
;;; 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))))
\f
;;; dumper for lists
;;; 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))
(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)))))))
\f
;;;; array dumping
;;; 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
(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
;; 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)))
;;; 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))
;;; 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
;; 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))
\f
;;;; 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
;; 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
;; 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
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
(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)
(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
;;; 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
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)))
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
(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.)
(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)
(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)
;;; 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))
\f
;;;; 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
(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))
;;;; 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
`(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))
(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*))
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
\f
;;;; 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)
(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))))
\f
(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)
(ceiling (* len sizebits)
sb!vm:byte-bits))))
(read-sequence-or-die (descriptor-bytes result)
- *fasl-file*
+ *fasl-input-stream*
:start start
:end end)
result))
(ash sb!vm:vector-data-offset sb!vm:word-shift)))
(end (+ start (* len sb!vm:word-bytes))))
(read-sequence-or-die (descriptor-bytes result)
- *fasl-file*
+ *fasl-input-stream*
:start start
:end end)
result))
#!+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))
;; 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))
#!+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))
;; 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))
(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*
(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
(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))
(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))
;;;; 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.
(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))
(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)
(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)
(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*))
*compiler-trace-output*))
(etypecase *compile-object*
- (fasl-file
+ (fasl-output
(maybe-mumble "fasl")
(fasl-dump-component component
*code-segment*
(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)
;;;;
;;;; (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.
(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))))))))))))
\f
;;;; COMPILE-FILE
(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))
(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))))
(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)
(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))
(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)))
(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))))
;;; 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))
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
(pathname output-file))
+\f
+;;;; 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))))))))))))
(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*))
\f
;;;; 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)))
\f
+;;;; 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)))
(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)
(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))))
+\f
+;;;; 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))
;;;; 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)
;;; 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
;; 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.
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)))
(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)
(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)
(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)
(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)
(: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)
(: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.
(: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*)))
\f
;;;; NLX entry VOPs
(define-vop (nlx-entry)
;; 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
;;
*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*
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);
+ }
}
\f
("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")
("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")
#!+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
(when (find-package public-package)
(check-ext-symbols-arglist public-package)))
(terpri)
+(print "done with interface.pure.lisp")
"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))))
+\f
+;;;; success
(quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff