1 ;;;; parts of the loader which make sense in the cross-compilation
2 ;;;; host (and which are useful in the host, because they're used by
5 ;;;; based on the CMU CL load.lisp code, written by Skef Wholey and
8 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
17 (in-package "SB!FASL")
19 ;;;; There looks to be an exciting amount of state being modified
20 ;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess
21 ;;;; around deciding how to thread-safetify it. So we use a Big Lock.
22 ;;;; Because this code is mutually recursive with the compiler, we use
23 ;;;; the **WORLD-LOCK**.
25 ;;;; miscellaneous load utilities
27 ;;; Output the current number of semicolons after a fresh-line.
28 ;;; FIXME: non-mnemonic name
29 (defun load-fresh-line ()
31 (let ((semicolons ";;;;;;;;;;;;;;;;"))
32 (do ((count *load-depth
* (- count
(length semicolons
))))
33 ((< count
(length semicolons
))
34 (write-string semicolons
*standard-output
* :end count
))
35 (declare (fixnum count
))
36 (write-string semicolons
))
37 (write-char #\space
)))
39 ;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how
40 ;;; we're loading from STREAM-WE-ARE-LOADING-FROM.
41 (defun maybe-announce-load (stream-we-are-loading-from verbose
)
44 (let ((name #-sb-xc-host
(file-name stream-we-are-loading-from
)
47 (format t
"loading ~S~%" name
)
48 (format t
"loading stuff from ~S~%" stream-we-are-loading-from
)))))
50 ;;;; utilities for reading from fasl files
52 #!-sb-fluid
(declaim (inline read-byte
))
54 ;;; This expands into code to read an N-byte unsigned integer using
56 (defmacro fast-read-u-integer
(n)
58 `(let ,(loop for i from
0 below n
59 collect
(let ((name (gensym "B")))
61 `(,name
,(if (zerop i
)
63 `(ash (fast-read-byte) ,(* i
8))))))
66 ;;; like FAST-READ-U-INTEGER, but the size may be determined at run time
67 (defmacro fast-read-var-u-integer
(n)
68 (let ((n-pos (gensym))
71 `(do ((,n-pos
8 (+ ,n-pos
8))
72 (,n-cnt
(1- ,n
) (1- ,n-cnt
))
75 (dpb (fast-read-byte) (byte 8 ,n-pos
) ,n-res
)))
76 ((zerop ,n-cnt
) ,n-res
)
77 (declare (type index
,n-pos
,n-cnt
)))))
79 ;;; FIXME: why do all of these reading functions and macros declare
80 ;;; (SPEED 0)? was there some bug in the compiler which has since
81 ;;; been fixed? --njf, 2004-09-08
83 ;;; Read a signed integer.
84 (defmacro fast-read-s-integer
(n)
85 (declare (optimize (speed 0)))
86 (let ((n-last (gensym)))
87 (do ((res `(let ((,n-last
(fast-read-byte)))
88 (if (zerop (logand ,n-last
#x80
))
90 (logior ,n-last
#x-100
)))
91 `(logior (fast-read-byte)
92 (ash (the (signed-byte ,(* cnt
8)) ,res
) 8)))
96 ;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*.
97 (defmacro read-arg
(n)
98 (declare (optimize (speed 0)))
100 `(the (unsigned-byte 8) (read-byte *fasl-input-stream
*))
101 `(with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
102 (fast-read-u-integer ,n
))))
104 ;; FIXME: on x86-64, these functions exceed 600, 900, and 1200 bytes of code
105 ;; respectively. Either don't inline them, or make a "really" fast inline case
106 ;; that punts if inapplicable. e.g. if the fast-read-byte buffer will not be
107 ;; refilled, then SAP-REF-WORD could work to read 8 bytes.
108 ;; But this would only be feasible on machines that are little-endian
109 ;; and that allow unaligned reads. (like x86)
110 (declaim (inline read-byte-arg read-halfword-arg read-word-arg
))
111 (defun read-byte-arg ()
112 (declare (optimize (speed 0)))
115 (defun read-halfword-arg ()
116 (declare (optimize (speed 0)))
117 (read-arg #.
(/ sb
!vm
:n-word-bytes
2)))
119 (defun read-word-arg ()
120 (declare (optimize (speed 0)))
121 (read-arg #.sb
!vm
:n-word-bytes
))
123 (defun read-unsigned-byte-32-arg ()
124 (declare (optimize (speed 0)))
130 ;;; The table is implemented as a simple-vector indexed by the table
131 ;;; offset. The offset is kept in at index 0 of the vector.
133 ;;; FOPs use the table to save stuff, other FOPs refer to the table by
134 ;;; direct indexes via REF-FOP-TABLE.
137 (declaim (simple-vector *fop-table
*))
139 (declaim (inline ref-fop-table
))
140 (defun ref-fop-table (index)
141 (declare (type index index
))
142 (svref *fop-table
* (the index
(+ index
1))))
144 (defun get-fop-table-index ()
145 (svref *fop-table
* 0))
147 (defun reset-fop-table ()
148 (setf (svref *fop-table
* 0) 0))
150 (defun push-fop-table (thing) ; and return THING
151 (let* ((table *fop-table
*)
152 (index (+ (the index
(aref table
0)) 1)))
153 (declare (fixnum index
)
154 (simple-vector table
))
155 (when (eql index
(length table
))
156 (setf table
(grow-fop-vector table index
)
158 (setf (aref table
0) index
159 (aref table index
) thing
)))
161 ;;; These three routines are used for both the stack and the table.
162 (defun make-fop-vector (size)
163 (declare (type index size
))
164 (let ((vector (make-array size
)))
165 (setf (aref vector
0) 0)
168 (defun grow-fop-vector (old-vector old-size
)
169 (declare (simple-vector old-vector
)
170 (type index old-size
))
171 (let* ((new-size (* old-size
2))
172 (new-vector (make-array new-size
)))
173 (declare (fixnum new-size
)
174 (simple-vector new-vector old-vector
))
175 (replace new-vector old-vector
)
176 (nuke-fop-vector old-vector
)
179 (defun nuke-fop-vector (vector)
180 (declare (simple-vector vector
)
181 #!-gencgc
(ignore vector
)
183 ;; Make sure we don't keep any garbage.
190 ;;; Much like the table, this is bound to a simple vector whose first
191 ;;; element is the current index.
193 (declaim (simple-vector *fop-stack
*))
195 (declaim (inline fop-stack-empty-p
))
196 (defun fop-stack-empty-p ()
197 (eql 0 (svref *fop-stack
* 0)))
199 ;; Ensure that N arguments can be popped from the FOP stack.
200 ;; Return the stack and the pointer to the first argument.
201 ;; Update the new top-of-stack to reflect that all N have been popped.
202 (defun fop-stack-pop-n (n)
203 (declare (type index n
))
204 (let* ((stack *fop-stack
*)
205 (top (the index
(svref stack
0)))
207 (if (minusp new-top
) ; 0 is ok at this point
208 (error "FOP stack underflow")
209 (progn (setf (svref stack
0) new-top
)
210 (values stack
(1+ new-top
))))))
212 (defun push-fop-stack (value)
213 (let* ((stack *fop-stack
*)
214 (next (1+ (the index
(svref stack
0)))))
215 (declare (type index next
))
216 (when (eql (length stack
) next
)
217 (setf stack
(grow-fop-vector stack next
)
219 (setf (svref stack
0) next
220 (svref stack next
) value
)))
223 ;;;; Conditions signalled on invalid fasls (wrong fasl version, etc),
224 ;;;; so that user code (esp. ASDF) can reasonably handle attempts to
225 ;;;; load such fasls by recompiling them, etc. For simplicity's sake
226 ;;;; make only condition INVALID-FASL part of the public interface,
227 ;;;; and keep the guts internal.
229 (define-condition invalid-fasl
(error)
230 ((stream :reader invalid-fasl-stream
:initarg
:stream
)
231 (expected :reader invalid-fasl-expected
:initarg
:expected
))
233 (lambda (condition stream
)
234 (format stream
"~S is an invalid fasl file."
235 (invalid-fasl-stream condition
)))))
237 (define-condition invalid-fasl-header
(invalid-fasl)
238 ((byte :reader invalid-fasl-byte
:initarg
:byte
)
239 (byte-nr :reader invalid-fasl-byte-nr
:initarg
:byte-nr
))
241 (lambda (condition stream
)
242 (format stream
"~@<~S contains an illegal byte in the FASL header at ~
243 position ~A: Expected ~A, got ~A.~:@>"
244 (invalid-fasl-stream condition
)
245 (invalid-fasl-byte-nr condition
)
246 (invalid-fasl-expected condition
)
247 (invalid-fasl-byte condition
)))))
249 (define-condition invalid-fasl-version
(invalid-fasl)
250 ((version :reader invalid-fasl-version
:initarg
:version
))
252 (lambda (condition stream
)
253 (format stream
"~@<~S is a fasl file compiled with SBCL ~W, and ~
254 can't be loaded into SBCL ~W.~:@>"
255 (invalid-fasl-stream condition
)
256 (invalid-fasl-version condition
)
257 (invalid-fasl-expected condition
)))))
259 (define-condition invalid-fasl-implementation
(invalid-fasl)
260 ((implementation :reader invalid-fasl-implementation
261 :initarg
:implementation
))
263 (lambda (condition stream
)
264 (format stream
"~S was compiled for implementation ~A, but this is a ~A."
265 (invalid-fasl-stream condition
)
266 (invalid-fasl-implementation condition
)
267 (invalid-fasl-expected condition
)))))
269 (define-condition invalid-fasl-features
(invalid-fasl)
270 ((potential-features :reader invalid-fasl-potential-features
271 :initarg
:potential-features
)
272 (features :reader invalid-fasl-features
:initarg
:features
))
274 (lambda (condition stream
)
275 (format stream
"~@<incompatible ~S in fasl file ~S: ~2I~_~
276 Of features affecting binary compatibility, ~4I~_~S~2I~_~
277 the fasl has ~4I~_~A,~2I~_~
278 while the runtime expects ~4I~_~A.~:>"
280 (invalid-fasl-stream condition
)
281 (invalid-fasl-potential-features condition
)
282 (invalid-fasl-features condition
)
283 (invalid-fasl-expected condition
)))))
285 ;;; Skips past the shebang line on stream, if any.
286 (defun maybe-skip-shebang-line (stream)
287 (let ((p (file-position stream
)))
288 (flet ((next () (read-byte stream nil
)))
290 (when (and (eq (next) (char-code #\
#))
291 (eq (next) (char-code #\
!)))
294 until
(or (not x
) (eq x
(char-code #\newline
)))))
296 (file-position stream p
))))
299 ;;; Returns T if the stream is a binary input stream with a FASL header.
300 (defun fasl-header-p (stream &key errorp
)
301 (unless (and (member (stream-element-type stream
) '(character base-char
))
302 ;; give up if it's not a file stream, or it's an
303 ;; fd-stream but it's either not bivalent or not
304 ;; seekable (doesn't really have a file)
305 (or (not (typep stream
'file-stream
))
306 (and (typep stream
'fd-stream
)
307 (or (not (sb!impl
::fd-stream-bivalent-p stream
))
308 (not (sb!impl
::fd-stream-file stream
))))))
309 (let ((p (file-position stream
)))
311 (let* ((header *fasl-header-string-start-string
*)
312 (buffer (make-array (length header
) :element-type
'(unsigned-byte 8)))
315 (maybe-skip-shebang-line stream
)
316 (setf n
(read-sequence buffer stream
))))
319 (or (ignore-errors (scan))
320 ;; no a binary input stream
321 (return-from fasl-header-p nil
))))
322 (if (mismatch buffer header
323 :test
#'(lambda (code char
) (= code
(char-code char
))))
324 ;; Immediate EOF is valid -- we want to match what
325 ;; CHECK-FASL-HEADER does...
328 (error 'fasl-header-missing
333 (file-position stream p
)))))
338 ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
339 ;;;; suitable modification of the fop table) in GENESIS. Therefore,
340 ;;;; it's needed not only in the target Lisp, but also in the
341 ;;;; cross-compilation host.
343 ;;; a helper function for LOAD-FASL-GROUP
345 ;;; Return true if we successfully read a FASL header from the stream, or NIL
346 ;;; if EOF was hit before anything except the optional shebang line was read.
347 ;;; Signal an error if we encounter garbage.
348 (defun check-fasl-header (stream)
349 (maybe-skip-shebang-line stream
)
350 (let ((byte (read-byte stream nil
)))
352 ;; Read and validate constant string prefix in fasl header.
353 (let* ((fhsss *fasl-header-string-start-string
*)
354 (fhsss-length (length fhsss
)))
355 (unless (= byte
(char-code (schar fhsss
0)))
356 (error 'invalid-fasl-header
360 :expected
(char-code (schar fhsss
0))))
361 (do ((byte (read-byte stream
) (read-byte stream
))
362 (count 1 (1+ count
)))
363 ((= byte
+fasl-header-string-stop-char-code
+)
365 (declare (fixnum byte count
))
366 (when (and (< count fhsss-length
)
367 (not (eql byte
(char-code (schar fhsss count
)))))
368 (error 'invalid-fasl-header
372 :expected
(char-code (schar fhsss count
))))))
373 ;; Read and validate version-specific compatibility stuff.
374 (flet ((string-from-stream ()
375 (let* ((length (read-unsigned-byte-32-arg))
376 (result (make-string length
)))
377 (read-string-as-bytes stream result
)
379 ;; Read and validate implementation and version.
380 (let ((implementation (keywordicate (string-from-stream)))
381 (expected-implementation +backend-fasl-file-implementation
+))
382 (unless (string= expected-implementation implementation
)
383 (error 'invalid-fasl-implementation
385 :implementation implementation
386 :expected expected-implementation
)))
387 (let* ((fasl-version (read-word-arg))
388 (sbcl-version (if (<= fasl-version
76)
390 (string-from-stream)))
391 (expected-version (sb!xc
:lisp-implementation-version
)))
392 (unless (string= expected-version sbcl-version
)
394 (error 'invalid-fasl-version
396 :version sbcl-version
397 :expected expected-version
)
398 (continue () :report
"Load the fasl file anyway"))))
399 ;; Read and validate *FEATURES* which affect binary compatibility.
400 (let ((faff-in-this-file (string-from-stream)))
401 (unless (string= faff-in-this-file
*features-affecting-fasl-format
*)
402 (error 'invalid-fasl-features
404 :potential-features
*features-potentially-affecting-fasl-format
*
405 :expected
*features-affecting-fasl-format
*
406 :features faff-in-this-file
)))
410 ;; Setting this variable gives you a trace of fops as they are loaded and
413 (defvar *show-fops-p
* nil
)
416 ;;; a helper function for LOAD-AS-FASL
418 ;;; Return true if we successfully load a group from the stream, or
419 ;;; NIL if EOF was encountered while trying to read from the stream.
420 ;;; Dispatch to the right function for each fop.
421 (defconstant +2-operand-fops
+ #xE0
) ; start of the range
422 (defun load-fasl-group (stream print
)
424 ;; PRINT causes most tlf-equivalent forms to print their primary value.
425 ;; This differs from loading of Lisp source, which prints all values of
426 ;; only truly-toplevel forms. This is permissible per CLHS -
427 ;; "If print is true, load incrementally prints information to standard
428 ;; output showing the progress of the loading process. [...]
429 ;; For a compiled file, what is printed might not reflect precisely the
430 ;; contents of the source file, but some information is generally printed."
432 (declare (ignorable print
))
433 (unless (check-fasl-header stream
)
434 (return-from load-fasl-group
))
435 (catch 'fasl-group-end
437 (let ((*skip-until
* nil
))
438 (declare (special *skip-until
*))
440 (let ((byte (the (unsigned-byte 8) (read-byte stream
)))
441 (trace (or #!+sb-show
*show-fops-p
*)))
442 ;; Do some debugging output.
444 (format *trace-output
* "~&~6x : [~D,~D] ~2,'0x(~A)"
445 (1- (file-position stream
))
446 (svref *fop-stack
* 0) ; stack pointer
447 (svref *fop-table
* 0) ; table pointer
448 byte
(aref *fop-names
* byte
)))
449 ;; Actually execute the fop.
451 (let ((function (svref *fop-funs
* byte
)))
452 (cond ((not (functionp function
))
453 (error "corrupt fasl file: FOP code #x~x" byte
))
454 ((zerop (sbit (car *fop-signatures
*) (ash byte -
2)))
455 (funcall function
)) ; takes no arguments
457 (let (arg1 arg2
) ; See !%DEFINE-FOP for encoding
458 (with-fast-read-byte ((unsigned-byte 8) stream
)
459 (setq arg1
(fast-read-var-u-integer
460 (ash 1 (logand byte
3))))
461 (when (>= byte
+2-operand-fops
+)
462 (setq arg2
(fast-read-var-u-integer
463 (ash 1 (ldb (byte 2 2) byte
))))))
465 (format *trace-output
* "{~D~@[,~D~]}" arg1 arg2
))
467 (funcall function arg1 arg2
)
468 (funcall function arg1
))))))))
469 (when (plusp (sbit (cdr *fop-signatures
*) byte
))
470 (push-fop-stack result
))
472 (let* ((stack *fop-stack
*)
473 (ptr (svref stack
0)))
474 (format *trace-output
* " -- ~[<empty>,~D~:;[~:*~D,~D] ~S~]"
475 ptr
(svref *fop-table
* 0)
476 (unless (eql ptr
0) (aref stack ptr
)))
477 (terpri *trace-output
*)))
479 (macrolet ((terminator-opcode ()
480 (or (get 'fop-funcall-for-effect
'opcode
)
481 (error "Missing FOP definition?"))))
483 (eq byte
(terminator-opcode))
484 (fop-stack-empty-p)) ; (presumed) end of TLF
486 (prin1 result
)))))))))
488 (defun load-as-fasl (stream verbose print
)
489 (when (zerop (file-length stream
))
490 (error "attempt to load an empty FASL file:~% ~S" (namestring stream
)))
491 (maybe-announce-load stream verbose
)
492 (let* ((*fasl-input-stream
* stream
)
493 (*fop-table
* (make-fop-vector 1000))
494 (*fop-stack
* (make-fop-vector 100)))
496 (loop while
(load-fasl-group stream print
))
497 ;; Nuke the table and stack to avoid keeping garbage on
498 ;; conservatively collected platforms.
499 (nuke-fop-vector *fop-table
*)
500 (nuke-fop-vector *fop-stack
*)))
503 (declaim (notinline read-byte
)) ; Why is it even *declaimed* inline above?
505 ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
508 (defvar *fop-counts
* (make-array 256 :initial-element
0))
509 (defvar *fop-times
* (make-array 256 :initial-element
0))
510 (defvar *print-fops
* nil
)
512 (defun clear-counts ()
513 (fill (the simple-vector
*fop-counts
*) 0)
514 (fill (the simple-vector
*fop-times
*) 0)
517 (defun analyze-counts ()
522 (macrolet ((breakdown (lvar tvar vec
)
526 (let ((n (svref ,vec i
)))
527 (push (cons (svref *fop-names
* i
) n
) ,lvar
)
529 (setq ,lvar
(subseq (sort ,lvar
(lambda (x y
)
530 (> (cdr x
) (cdr y
))))
533 (breakdown counts total-count
*fop-counts
*)
534 (breakdown times total-time
*fop-times
*)
535 (format t
"Total fop count is ~D~%" total-count
)
537 (format t
"~30S: ~4D~%" (car c
) (cdr c
)))
538 (format t
"~%Total fop time is ~D~%" (/ (float total-time
) 60.0))
540 (format t
"~30S: ~6,2F~%" (car m
) (/ (float (cdr m
)) 60.0))))))