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 FASL-INPUT-STREAM.
97 (defmacro read-arg
(n fasl-input-stream
)
99 `(the (unsigned-byte 8) (read-byte ,fasl-input-stream
))
100 `(with-fast-read-byte ((unsigned-byte 8) ,fasl-input-stream
)
101 (fast-read-u-integer ,n
))))
103 ;; FIXME: on x86-64, these functions exceed 600, 900, and 1200 bytes of code
104 ;; respectively. Either don't inline them, or make a "really" fast inline case
105 ;; that punts if inapplicable. e.g. if the fast-read-byte buffer will not be
106 ;; refilled, then SAP-REF-WORD could work to read 8 bytes.
107 ;; But this would only be feasible on machines that are little-endian
108 ;; and that allow unaligned reads. (like x86)
109 (declaim (inline read-byte-arg read-halfword-arg read-word-arg
))
110 (defun read-byte-arg (stream)
111 (declare (optimize (speed 0)))
114 (defun read-halfword-arg (stream)
115 (declare (optimize (speed 0)))
116 (read-arg #.
(/ sb
!vm
:n-word-bytes
2) stream
)) ; READ-ARG doesn't eval N
118 (defun read-word-arg (stream)
119 (declare (optimize (speed 0)))
120 (read-arg #.sb
!vm
:n-word-bytes stream
))
122 (defun read-unsigned-byte-32-arg (stream)
123 (declare (optimize (speed 0)))
129 ;;; The table is implemented as a simple-vector indexed by the table
130 ;;; offset. The offset is kept in at index 0 of the vector.
132 ;;; FOPs use the table to save stuff, other FOPs refer to the table by
133 ;;; direct indexes via REF-FOP-TABLE.
135 (declaim (inline ref-fop-table
))
136 (defun ref-fop-table (fasl-input index
)
137 (svref (%fasl-input-table fasl-input
) (1+ (the index index
))))
139 (defun push-fop-table (thing fasl-input
) ; and return THING
140 (let* ((table (%fasl-input-table fasl-input
))
141 (index (+ (the index
(aref table
0)) 1)))
142 (declare (fixnum index
)
143 (simple-vector table
))
144 (when (eql index
(length table
))
145 (setf table
(grow-fop-vector table index
)
146 (%fasl-input-table fasl-input
) table
))
147 (setf (aref table
0) index
148 (aref table index
) thing
)))
150 ;;; These three routines are used for both the stack and the table.
151 (defun make-fop-vector (size)
152 (declare (type index size
))
153 (let ((vector (make-array size
)))
154 (setf (aref vector
0) 0)
157 (defun grow-fop-vector (old-vector old-size
)
158 (declare (simple-vector old-vector
)
159 (type index old-size
))
160 (let* ((new-size (* old-size
2))
161 (new-vector (make-array new-size
)))
162 (declare (fixnum new-size
)
163 (simple-vector new-vector old-vector
))
164 (replace new-vector old-vector
)
165 (nuke-fop-vector old-vector
)
168 (defun nuke-fop-vector (vector)
169 (declare (simple-vector vector
)
170 #!-gencgc
(ignore vector
)
172 ;; Make sure we don't keep any garbage.
179 (declaim (inline fop-stack-empty-p
))
180 (defun fop-stack-empty-p (stack)
181 (eql 0 (svref stack
0)))
183 ;; Ensure that N arguments can be popped from the FOP stack.
184 ;; Return the stack and the pointer to the first argument.
185 ;; Update the new top-of-stack to reflect that all N have been popped.
186 (defun fop-stack-pop-n (stack n
)
187 (declare (type index n
))
188 (let* ((top (the index
(svref stack
0)))
190 (if (minusp new-top
) ; 0 is ok at this point
191 (error "FOP stack underflow")
192 (progn (setf (svref stack
0) new-top
)
195 (defun push-fop-stack (value fasl-input
)
196 (let* ((stack (%fasl-input-stack fasl-input
))
197 (next (1+ (the index
(svref stack
0)))))
198 (declare (type index next
))
199 (when (eql (length stack
) next
)
200 (setf stack
(grow-fop-vector stack next
)
201 (%fasl-input-stack fasl-input
) stack
))
202 (setf (svref stack
0) next
203 (svref stack next
) value
)))
206 ;;;; Conditions signalled on invalid fasls (wrong fasl version, etc),
207 ;;;; so that user code (esp. ASDF) can reasonably handle attempts to
208 ;;;; load such fasls by recompiling them, etc. For simplicity's sake
209 ;;;; make only condition INVALID-FASL part of the public interface,
210 ;;;; and keep the guts internal.
212 (define-condition invalid-fasl
(error)
213 ((stream :reader invalid-fasl-stream
:initarg
:stream
)
214 (expected :reader invalid-fasl-expected
:initarg
:expected
))
216 (lambda (condition stream
)
217 (format stream
"~S is an invalid fasl file."
218 (invalid-fasl-stream condition
)))))
220 (define-condition invalid-fasl-header
(invalid-fasl)
221 ((byte :reader invalid-fasl-byte
:initarg
:byte
)
222 (byte-nr :reader invalid-fasl-byte-nr
:initarg
:byte-nr
))
224 (lambda (condition stream
)
225 (format stream
"~@<~S contains an illegal byte in the FASL header at ~
226 position ~A: Expected ~A, got ~A.~:@>"
227 (invalid-fasl-stream condition
)
228 (invalid-fasl-byte-nr condition
)
229 (invalid-fasl-expected condition
)
230 (invalid-fasl-byte condition
)))))
232 (define-condition invalid-fasl-version
(invalid-fasl)
233 ((version :reader invalid-fasl-version
:initarg
:version
))
235 (lambda (condition stream
)
236 (format stream
"~@<~S is a fasl file compiled with SBCL ~W, and ~
237 can't be loaded into SBCL ~W.~:@>"
238 (invalid-fasl-stream condition
)
239 (invalid-fasl-version condition
)
240 (invalid-fasl-expected condition
)))))
242 (define-condition invalid-fasl-implementation
(invalid-fasl)
243 ((implementation :reader invalid-fasl-implementation
244 :initarg
:implementation
))
246 (lambda (condition stream
)
247 (format stream
"~S was compiled for implementation ~A, but this is a ~A."
248 (invalid-fasl-stream condition
)
249 (invalid-fasl-implementation condition
)
250 (invalid-fasl-expected condition
)))))
252 (define-condition invalid-fasl-features
(invalid-fasl)
253 ((potential-features :reader invalid-fasl-potential-features
254 :initarg
:potential-features
)
255 (features :reader invalid-fasl-features
:initarg
:features
))
257 (lambda (condition stream
)
258 (format stream
"~@<incompatible ~S in fasl file ~S: ~2I~_~
259 Of features affecting binary compatibility, ~4I~_~S~2I~_~
260 the fasl has ~4I~_~A,~2I~_~
261 while the runtime expects ~4I~_~A.~:>"
263 (invalid-fasl-stream condition
)
264 (invalid-fasl-potential-features condition
)
265 (invalid-fasl-features condition
)
266 (invalid-fasl-expected condition
)))))
268 ;;; Skips past the shebang line on stream, if any.
269 (defun maybe-skip-shebang-line (stream)
270 (let ((p (file-position stream
)))
271 (flet ((next () (read-byte stream nil
)))
273 (when (and (eq (next) (char-code #\
#))
274 (eq (next) (char-code #\
!)))
277 until
(or (not x
) (eq x
(char-code #\newline
)))))
279 (file-position stream p
))))
282 ;;; Returns T if the stream is a binary input stream with a FASL header.
283 (defun fasl-header-p (stream &key errorp
)
284 (unless (and (member (stream-element-type stream
) '(character base-char
))
285 ;; give up if it's not a file stream, or it's an
286 ;; fd-stream but it's either not bivalent or not
287 ;; seekable (doesn't really have a file)
288 (or (not (typep stream
'file-stream
))
289 (and (typep stream
'fd-stream
)
290 (or (not (sb!impl
::fd-stream-bivalent-p stream
))
291 (not (sb!impl
::fd-stream-file stream
))))))
292 (let ((p (file-position stream
)))
294 (let* ((header *fasl-header-string-start-string
*)
295 (buffer (make-array (length header
) :element-type
'(unsigned-byte 8)))
298 (maybe-skip-shebang-line stream
)
299 (setf n
(read-sequence buffer stream
))))
302 (or (ignore-errors (scan))
303 ;; no a binary input stream
304 (return-from fasl-header-p nil
))))
305 (if (mismatch buffer header
306 :test
#'(lambda (code char
) (= code
(char-code char
))))
307 ;; Immediate EOF is valid -- we want to match what
308 ;; CHECK-FASL-HEADER does...
311 (error 'fasl-header-missing
316 (file-position stream p
)))))
321 ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
322 ;;;; suitable modification of the fop table) in GENESIS. Therefore,
323 ;;;; it's needed not only in the target Lisp, but also in the
324 ;;;; cross-compilation host.
326 ;;; a helper function for LOAD-FASL-GROUP
328 ;;; Return true if we successfully read a FASL header from the stream, or NIL
329 ;;; if EOF was hit before anything except the optional shebang line was read.
330 ;;; Signal an error if we encounter garbage.
331 (defun check-fasl-header (stream)
332 (maybe-skip-shebang-line stream
)
333 (let ((byte (read-byte stream nil
)))
335 ;; Read and validate constant string prefix in fasl header.
336 (let* ((fhsss *fasl-header-string-start-string
*)
337 (fhsss-length (length fhsss
)))
338 (unless (= byte
(char-code (schar fhsss
0)))
339 (error 'invalid-fasl-header
343 :expected
(char-code (schar fhsss
0))))
344 (do ((byte (read-byte stream
) (read-byte stream
))
345 (count 1 (1+ count
)))
346 ((= byte
+fasl-header-string-stop-char-code
+)
348 (declare (fixnum byte count
))
349 (when (and (< count fhsss-length
)
350 (not (eql byte
(char-code (schar fhsss count
)))))
351 (error 'invalid-fasl-header
355 :expected
(char-code (schar fhsss count
))))))
356 ;; Read and validate version-specific compatibility stuff.
357 (flet ((string-from-stream ()
358 (let* ((length (read-unsigned-byte-32-arg stream
))
359 (result (make-string length
)))
360 (read-string-as-bytes stream result
)
362 ;; Read and validate implementation and version.
363 (let ((implementation (keywordicate (string-from-stream)))
364 (expected-implementation +backend-fasl-file-implementation
+))
365 (unless (string= expected-implementation implementation
)
366 (error 'invalid-fasl-implementation
368 :implementation implementation
369 :expected expected-implementation
)))
370 (let* ((fasl-version (read-word-arg stream
))
371 (sbcl-version (if (<= fasl-version
76)
373 (string-from-stream)))
374 (expected-version (sb!xc
:lisp-implementation-version
)))
375 (unless (string= expected-version sbcl-version
)
377 (error 'invalid-fasl-version
379 :version sbcl-version
380 :expected expected-version
)
381 (continue () :report
"Load the fasl file anyway"))))
382 ;; Read and validate *FEATURES* which affect binary compatibility.
383 (let ((faff-in-this-file (string-from-stream)))
384 (unless (string= faff-in-this-file
*features-affecting-fasl-format
*)
385 (error 'invalid-fasl-features
387 :potential-features
*features-potentially-affecting-fasl-format
*
388 :expected
*features-affecting-fasl-format
*
389 :features faff-in-this-file
)))
393 ;; Setting this variable gives you a trace of fops as they are loaded and
396 (defvar *show-fops-p
* nil
)
399 ;;; a helper function for LOAD-AS-FASL
401 ;;; Return true if we successfully load a group from the stream, or
402 ;;; NIL if EOF was encountered while trying to read from the stream.
403 ;;; Dispatch to the right function for each fop.
404 (defconstant +2-operand-fops
+ #xE0
) ; start of the range
405 (defun load-fasl-group (fasl-input print
)
407 ;; PRINT causes most tlf-equivalent forms to print their primary value.
408 ;; This differs from loading of Lisp source, which prints all values of
409 ;; only truly-toplevel forms. This is permissible per CLHS -
410 ;; "If print is true, load incrementally prints information to standard
411 ;; output showing the progress of the loading process. [...]
412 ;; For a compiled file, what is printed might not reflect precisely the
413 ;; contents of the source file, but some information is generally printed."
415 (declare (ignorable print
))
416 (let ((stream (%fasl-input-stream fasl-input
)))
417 (unless (check-fasl-header stream
)
418 (return-from load-fasl-group
))
419 (catch 'fasl-group-end
420 (setf (svref (%fasl-input-table fasl-input
) 0) 0)
422 (let ((byte (the (unsigned-byte 8) (read-byte stream
)))
423 (trace (or #!+sb-show
*show-fops-p
*)))
424 ;; Do some debugging output.
426 (format *trace-output
* "~&~6x : [~D,~D] ~2,'0x(~A)"
427 (1- (file-position stream
))
428 (svref (%fasl-input-stack fasl-input
) 0) ; stack pointer
429 (svref (%fasl-input-table fasl-input
) 0) ; table pointer
430 byte
(aref **fop-names
** byte
)))
431 ;; Actually execute the fop.
433 (let ((function (svref **fop-funs
** byte
)))
434 (cond ((not (functionp function
))
435 (error "corrupt fasl file: FOP code #x~x" byte
))
436 ((zerop (sbit (car **fop-signatures
**) (ash byte -
2)))
437 ;; takes no arguments from the fasl file
438 (funcall function fasl-input
))
440 ;; one or two arguments come from the fasl file
441 (let (arg1 arg2
) ; See !%DEFINE-FOP for encoding
442 (with-fast-read-byte ((unsigned-byte 8) stream
)
443 (setq arg1
(fast-read-var-u-integer
444 (ash 1 (logand byte
3))))
445 (when (>= byte
+2-operand-fops
+)
446 (setq arg2
(fast-read-var-u-integer
447 (ash 1 (ldb (byte 2 2) byte
))))))
449 (format *trace-output
* "{~D~@[,~D~]}" arg1 arg2
))
451 (funcall function fasl-input arg1 arg2
)
452 (funcall function fasl-input arg1
))))))))
453 (when (plusp (sbit (cdr **fop-signatures
**) byte
))
454 (push-fop-stack result fasl-input
))
455 (let* ((stack (%fasl-input-stack fasl-input
))
456 (ptr (svref stack
0)))
458 (format *trace-output
* " -- ~[<empty>,~D~:;[~:*~D,~D] ~S~]"
459 ptr
(svref (%fasl-input-table fasl-input
) 0)
460 (unless (eql ptr
0) (aref stack ptr
)))
461 (terpri *trace-output
*))
463 (macrolet ((terminator-opcode ()
464 (or (get 'fop-funcall-for-effect
'opcode
)
465 (error "Missing FOP definition?"))))
466 (when (and (eq byte
(terminator-opcode))
467 (fop-stack-empty-p stack
)) ; (presumed) end of TLF
468 (awhen (%fasl-input-deprecated-stuff fasl-input
)
469 ;; Delaying this message rather than printing it
470 ;; in fop-fdefn makes it more informative (usually).
471 (setf (%fasl-input-deprecated-stuff fasl-input
) nil
)
472 (loader-deprecation-warn
474 (and (eq (svref stack
1) 'sb
!impl
::%defun
) (svref stack
2))))
477 (prin1 result
)))))))))))
479 (defun load-as-fasl (stream verbose print
)
480 (when (zerop (file-length stream
))
481 (error "attempt to load an empty FASL file:~% ~S" (namestring stream
)))
482 (maybe-announce-load stream verbose
)
483 (let ((fasl-input (make-fasl-input stream
)))
485 (loop while
(load-fasl-group fasl-input print
))
486 ;; Nuke the table and stack to avoid keeping garbage on
487 ;; conservatively collected platforms.
488 (nuke-fop-vector (%fasl-input-table fasl-input
))
489 (nuke-fop-vector (%fasl-input-stack fasl-input
))))
492 (declaim (notinline read-byte
)) ; Why is it even *declaimed* inline above?
494 ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
497 (defvar *fop-counts
* (make-array 256 :initial-element
0))
498 (defvar *fop-times
* (make-array 256 :initial-element
0))
499 (defvar *print-fops
* nil
)
501 (defun clear-counts ()
502 (fill (the simple-vector
*fop-counts
*) 0)
503 (fill (the simple-vector
*fop-times
*) 0)
506 (defun analyze-counts ()
511 (macrolet ((breakdown (lvar tvar vec
)
515 (let ((n (svref ,vec i
)))
516 (push (cons (svref *fop-names
* i
) n
) ,lvar
)
518 (setq ,lvar
(subseq (sort ,lvar
(lambda (x y
)
519 (> (cdr x
) (cdr y
))))
522 (breakdown counts total-count
*fop-counts
*)
523 (breakdown times total-time
*fop-times
*)
524 (format t
"Total fop count is ~D~%" total-count
)
526 (format t
"~30S: ~4D~%" (car c
) (cdr c
)))
527 (format t
"~%Total fop time is ~D~%" (/ (float total-time
) 60.0))
529 (format t
"~30S: ~6,2F~%" (car m
) (/ (float (cdr m
)) 60.0))))))