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 two routines are used for both the stack and the table.
151 (defun grow-fop-vector (old-vector old-size
)
152 (declare (simple-vector old-vector
)
153 (type index old-size
))
154 (let* ((new-size (* old-size
2))
155 (new-vector (make-array new-size
)))
156 (declare (fixnum new-size
)
157 (simple-vector new-vector old-vector
))
158 (replace new-vector old-vector
)
159 (nuke-fop-vector old-vector
)
162 (defun nuke-fop-vector (vector)
163 (declare (simple-vector vector
)
164 #!-gencgc
(ignore vector
)
166 ;; Make sure we don't keep any garbage.
173 (declaim (inline fop-stack-empty-p
))
174 (defun fop-stack-empty-p (stack)
175 (eql 0 (svref stack
0)))
177 ;; Ensure that N arguments can be popped from the FOP stack.
178 ;; Return the stack and the pointer to the first argument.
179 ;; Update the new top-of-stack to reflect that all N have been popped.
180 (defun fop-stack-pop-n (stack n
)
181 (declare (type index n
))
182 (let* ((top (the index
(svref stack
0)))
184 (if (minusp new-top
) ; 0 is ok at this point
185 (error "FOP stack underflow")
186 (progn (setf (svref stack
0) new-top
)
189 (defun push-fop-stack (value fasl-input
)
190 (let* ((stack (%fasl-input-stack fasl-input
))
191 (next (1+ (the index
(svref stack
0)))))
192 (declare (type index next
))
193 (when (eql (length stack
) next
)
194 (setf stack
(grow-fop-vector stack next
)
195 (%fasl-input-stack fasl-input
) stack
))
196 (setf (svref stack
0) next
197 (svref stack next
) value
)))
200 ;;;; Conditions signalled on invalid fasls (wrong fasl version, etc),
201 ;;;; so that user code (esp. ASDF) can reasonably handle attempts to
202 ;;;; load such fasls by recompiling them, etc. For simplicity's sake
203 ;;;; make only condition INVALID-FASL part of the public interface,
204 ;;;; and keep the guts internal.
206 (define-condition invalid-fasl
(error)
207 ((stream :reader invalid-fasl-stream
:initarg
:stream
)
208 (expected :reader invalid-fasl-expected
:initarg
:expected
))
210 (lambda (condition stream
)
211 (format stream
"~S is an invalid fasl file."
212 (invalid-fasl-stream condition
)))))
214 (define-condition invalid-fasl-header
(invalid-fasl)
215 ((byte :reader invalid-fasl-byte
:initarg
:byte
)
216 (byte-nr :reader invalid-fasl-byte-nr
:initarg
:byte-nr
))
218 (lambda (condition stream
)
219 (format stream
"~@<~S contains an illegal byte in the FASL header at ~
220 position ~A: Expected ~A, got ~A.~:@>"
221 (invalid-fasl-stream condition
)
222 (invalid-fasl-byte-nr condition
)
223 (invalid-fasl-expected condition
)
224 (invalid-fasl-byte condition
)))))
226 (define-condition invalid-fasl-version
(invalid-fasl)
227 ((version :reader invalid-fasl-version
:initarg
:version
))
229 (lambda (condition stream
)
230 (format stream
"~@<~S is a fasl file compiled with SBCL ~W, and ~
231 can't be loaded into SBCL ~W.~:@>"
232 (invalid-fasl-stream condition
)
233 (invalid-fasl-version condition
)
234 (invalid-fasl-expected condition
)))))
236 (define-condition invalid-fasl-implementation
(invalid-fasl)
237 ((implementation :reader invalid-fasl-implementation
238 :initarg
:implementation
))
240 (lambda (condition stream
)
241 (format stream
"~S was compiled for implementation ~A, but this is a ~A."
242 (invalid-fasl-stream condition
)
243 (invalid-fasl-implementation condition
)
244 (invalid-fasl-expected condition
)))))
246 (define-condition invalid-fasl-features
(invalid-fasl)
247 ((potential-features :reader invalid-fasl-potential-features
248 :initarg
:potential-features
)
249 (features :reader invalid-fasl-features
:initarg
:features
))
251 (lambda (condition stream
)
252 (format stream
"~@<incompatible ~S in fasl file ~S: ~2I~_~
253 Of features affecting binary compatibility, ~4I~_~S~2I~_~
254 the fasl has ~4I~_~A,~2I~_~
255 while the runtime expects ~4I~_~A.~:>"
257 (invalid-fasl-stream condition
)
258 (invalid-fasl-potential-features condition
)
259 (invalid-fasl-features condition
)
260 (invalid-fasl-expected condition
)))))
262 ;;; Skips past the shebang line on stream, if any.
263 (defun maybe-skip-shebang-line (stream)
264 (let ((p (file-position stream
)))
265 (flet ((next () (read-byte stream nil
)))
267 (when (and (eq (next) (char-code #\
#))
268 (eq (next) (char-code #\
!)))
271 until
(or (not x
) (eq x
(char-code #\newline
)))))
273 (file-position stream p
))))
276 ;;; Returns T if the stream is a binary input stream with a FASL header.
277 #-sb-xc-host
;; FIXME: function belongs in 'target-load'
278 (defun fasl-header-p (stream &key errorp
)
279 (unless (and (member (stream-element-type stream
) '(character base-char
))
280 ;; give up if it's not a file stream, or it's an
281 ;; fd-stream but it's either not bivalent or not
282 ;; seekable (doesn't really have a file)
283 (or (not (typep stream
'file-stream
))
284 (and (typep stream
'fd-stream
)
285 (or (not (sb!impl
::fd-stream-bivalent-p stream
))
286 (not (sb!impl
::fd-stream-file stream
))))))
287 (let ((p (file-position stream
)))
289 (let* ((header *fasl-header-string-start-string
*)
290 (buffer (make-array (length header
) :element-type
'(unsigned-byte 8)))
293 (maybe-skip-shebang-line stream
)
294 (setf n
(read-sequence buffer stream
))))
297 (or (ignore-errors (scan))
298 ;; no a binary input stream
299 (return-from fasl-header-p nil
))))
300 (if (mismatch buffer header
301 :test
#'(lambda (code char
) (= code
(char-code char
))))
302 ;; Immediate EOF is valid -- we want to match what
303 ;; CHECK-FASL-HEADER does...
306 (error 'fasl-header-missing
311 (file-position stream p
)))))
316 ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
317 ;;;; suitable modification of the fop table) in GENESIS. Therefore,
318 ;;;; it's needed not only in the target Lisp, but also in the
319 ;;;; cross-compilation host.
321 ;;; a helper function for LOAD-FASL-GROUP
323 ;;; Return true if we successfully read a FASL header from the stream, or NIL
324 ;;; if EOF was hit before anything except the optional shebang line was read.
325 ;;; Signal an error if we encounter garbage.
326 (defun check-fasl-header (stream)
327 (maybe-skip-shebang-line stream
)
328 (let ((byte (read-byte stream nil
)))
330 ;; Read and validate constant string prefix in fasl header.
331 (let* ((fhsss *fasl-header-string-start-string
*)
332 (fhsss-length (length fhsss
)))
333 (unless (= byte
(char-code (schar fhsss
0)))
334 (error 'invalid-fasl-header
338 :expected
(char-code (schar fhsss
0))))
339 (do ((byte (read-byte stream
) (read-byte stream
))
340 (count 1 (1+ count
)))
341 ((= byte
+fasl-header-string-stop-char-code
+)
343 (declare (fixnum byte count
))
344 (when (and (< count fhsss-length
)
345 (not (eql byte
(char-code (schar fhsss count
)))))
346 (error 'invalid-fasl-header
350 :expected
(char-code (schar fhsss count
))))))
351 ;; Read and validate version-specific compatibility stuff.
352 (flet ((string-from-stream ()
353 (let* ((length (read-unsigned-byte-32-arg stream
))
354 (result (make-string length
)))
355 (read-string-as-bytes stream result
)
357 ;; Read and validate implementation and version.
358 (let ((implementation (keywordicate (string-from-stream)))
359 (expected-implementation +backend-fasl-file-implementation
+))
360 (unless (string= expected-implementation implementation
)
361 (error 'invalid-fasl-implementation
363 :implementation implementation
364 :expected expected-implementation
)))
365 (let* ((fasl-version (read-word-arg stream
))
366 (sbcl-version (if (<= fasl-version
76)
368 (string-from-stream)))
369 (expected-version (sb!xc
:lisp-implementation-version
)))
370 (unless (string= expected-version sbcl-version
)
372 (error 'invalid-fasl-version
374 :version sbcl-version
375 :expected expected-version
)
376 (continue () :report
"Load the fasl file anyway"))))
377 ;; Read and validate *FEATURES* which affect binary compatibility.
378 (let ((faff-in-this-file (string-from-stream)))
379 (unless (string= faff-in-this-file
*features-affecting-fasl-format
*)
380 (error 'invalid-fasl-features
382 :potential-features
*features-potentially-affecting-fasl-format
*
383 :expected
*features-affecting-fasl-format
*
384 :features faff-in-this-file
)))
388 ;; Setting this variable gives you a trace of fops as they are loaded and
391 (defvar *show-fops-p
* nil
)
394 ;;; a helper function for LOAD-AS-FASL
396 ;;; Return true if we successfully load a group from the stream, or
397 ;;; NIL if EOF was encountered while trying to read from the stream.
398 ;;; Dispatch to the right function for each fop.
399 (defconstant +2-operand-fops
+ #xE0
) ; start of the range
400 (defun load-fasl-group (fasl-input print
)
402 ;; PRINT causes most tlf-equivalent forms to print their primary value.
403 ;; This differs from loading of Lisp source, which prints all values of
404 ;; only truly-toplevel forms. This is permissible per CLHS -
405 ;; "If print is true, load incrementally prints information to standard
406 ;; output showing the progress of the loading process. [...]
407 ;; For a compiled file, what is printed might not reflect precisely the
408 ;; contents of the source file, but some information is generally printed."
410 (declare (ignorable print
))
411 (let ((stream (%fasl-input-stream fasl-input
))
412 #!+sb-show
(trace *show-fops-p
*))
413 (unless (check-fasl-header stream
)
414 (return-from load-fasl-group
))
415 (catch 'fasl-group-end
416 (setf (svref (%fasl-input-table fasl-input
) 0) 0)
417 (macrolet ((tracing (&body forms
)
418 #!+sb-show
`(when trace
,@forms
)
419 #!-sb-show
(progn forms nil
)))
421 (let ((byte (the (unsigned-byte 8) (read-byte stream
))))
422 ;; Do some debugging output.
424 (format *trace-output
* "~&~6x : [~D,~D] ~2,'0x(~A)"
425 (1- (file-position stream
))
426 (svref (%fasl-input-stack fasl-input
) 0) ; stack pointer
427 (svref (%fasl-input-table fasl-input
) 0) ; table pointer
428 byte
(aref **fop-names
** byte
)))
429 ;; Actually execute the fop.
431 (let ((function (svref **fop-funs
** byte
)))
432 (cond ((not (functionp function
))
433 (error "corrupt fasl file: FOP code #x~x" byte
))
434 ((zerop (sbit (car **fop-signatures
**) (ash byte -
2)))
435 ;; takes no arguments from the fasl file
436 (funcall function fasl-input
))
438 ;; one or two arguments come from the fasl file
439 (let (arg1 arg2
) ; See !%DEFINE-FOP for encoding
440 (with-fast-read-byte ((unsigned-byte 8) stream
)
441 (setq arg1
(fast-read-var-u-integer
442 (ash 1 (logand byte
3))))
443 (when (>= byte
+2-operand-fops
+)
444 (setq arg2
(fast-read-var-u-integer
445 (ash 1 (ldb (byte 2 2) byte
))))))
447 (format *trace-output
* "{~D~@[,~D~]}" arg1 arg2
))
449 (funcall function fasl-input arg1 arg2
)
450 (funcall function fasl-input arg1
))))))))
451 (when (plusp (sbit (cdr **fop-signatures
**) byte
))
452 (push-fop-stack result fasl-input
))
453 (let ((stack (%fasl-input-stack fasl-input
)))
454 (declare (ignorable stack
)) ; not used in xc-host
456 (let ((ptr (svref stack
0)))
457 (format *trace-output
* " -- ~[<empty>,~D~:;[~:*~D,~D] ~S~]"
458 ptr
(svref (%fasl-input-table fasl-input
) 0)
459 (unless (eql ptr
0) (aref stack ptr
)))
460 (terpri *trace-output
*)))
462 (macrolet ((terminator-opcode ()
463 (or (get 'fop-funcall-for-effect
'opcode
)
464 (error "Missing FOP definition?"))))
465 (when (and (eq byte
(terminator-opcode))
466 (fop-stack-empty-p stack
)) ; (presumed) end of TLF
467 (awhen (%fasl-input-deprecated-stuff fasl-input
)
468 ;; Delaying this message rather than printing it
469 ;; in fop-fdefn makes it more informative (usually).
470 (setf (%fasl-input-deprecated-stuff fasl-input
) nil
)
471 (loader-deprecation-warn
473 (and (eq (svref stack
1) 'sb
!impl
::%defun
) (svref stack
2))))
476 (prin1 result
))))))))))))
478 (defun load-as-fasl (stream verbose print
)
479 (when (zerop (file-length stream
))
480 (error "attempt to load an empty FASL file:~% ~S" (namestring stream
)))
481 (maybe-announce-load stream verbose
)
482 (let ((fasl-input (make-fasl-input stream
)))
484 (loop while
(load-fasl-group fasl-input print
))
485 ;; Nuke the table and stack to avoid keeping garbage on
486 ;; conservatively collected platforms.
487 (nuke-fop-vector (%fasl-input-table fasl-input
))
488 (nuke-fop-vector (%fasl-input-stack fasl-input
))))
491 (declaim (notinline read-byte
)) ; Why is it even *declaimed* inline above?
493 ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
496 (defvar *fop-counts
* (make-array 256 :initial-element
0))
497 (defvar *fop-times
* (make-array 256 :initial-element
0))
498 (defvar *print-fops
* nil
)
500 (defun clear-counts ()
501 (fill (the simple-vector
*fop-counts
*) 0)
502 (fill (the simple-vector
*fop-times
*) 0)
505 (defun analyze-counts ()
510 (macrolet ((breakdown (lvar tvar vec
)
514 (let ((n (svref ,vec i
)))
515 (push (cons (svref *fop-names
* i
) n
) ,lvar
)
517 (setq ,lvar
(subseq (sort ,lvar
(lambda (x y
)
518 (> (cdr x
) (cdr y
))))
521 (breakdown counts total-count
*fop-counts
*)
522 (breakdown times total-time
*fop-times
*)
523 (format t
"Total fop count is ~D~%" total-count
)
525 (format t
"~30S: ~4D~%" (car c
) (cdr c
)))
526 (format t
"~%Total fop time is ~D~%" (/ (float total-time
) 60.0))
528 (format t
"~30S: ~6,2F~%" (car m
) (/ (float (cdr m
)) 60.0))))))