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 ;;;; miscellaneous load utilities
21 ;;; Output the current number of semicolons after a fresh-line.
22 ;;; FIXME: non-mnemonic name
23 (defun load-fresh-line ()
25 (let ((semicolons ";;;;;;;;;;;;;;;;"))
26 (do ((count *load-depth* (- count (length semicolons))))
27 ((< count (length semicolons))
28 (write-string semicolons *standard-output* :end count))
29 (declare (fixnum count))
30 (write-string semicolons))
31 (write-char #\space)))
33 ;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how we're
34 ;;; loading from STREAM-WE-ARE-LOADING-FROM.
35 ;;; FIXME: non-mnemonic name
36 (defun do-load-verbose (stream-we-are-loading-from verbose)
39 (let ((name #-sb-xc-host (file-name stream-we-are-loading-from)
42 (format t "loading ~S~%" name)
43 (format t "loading stuff from ~S~%" stream-we-are-loading-from)))))
45 ;;;; utilities for reading from fasl files
47 #!-sb-fluid (declaim (inline read-byte))
49 ;;; Expands into code to read an N-byte unsigned integer using
51 (defmacro fast-read-u-integer (n)
52 (declare (optimize (speed 0)))
53 (do ((res '(fast-read-byte)
54 `(logior (fast-read-byte)
59 ;;; Like Fast-Read-U-Integer, but the size may be determined at run time.
60 (defmacro fast-read-variable-u-integer (n)
61 (let ((n-pos (gensym))
64 `(do ((,n-pos 8 (+ ,n-pos 8))
65 (,n-cnt (1- ,n) (1- ,n-cnt))
68 (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
69 ((zerop ,n-cnt) ,n-res)
70 (declare (type index ,n-pos ,n-cnt)))))
72 ;;; Read a signed integer.
73 (defmacro fast-read-s-integer (n)
74 (declare (optimize (speed 0)))
75 (let ((n-last (gensym)))
76 (do ((res `(let ((,n-last (fast-read-byte)))
77 (if (zerop (logand ,n-last #x80))
79 (logior ,n-last #x-100)))
80 `(logior (fast-read-byte)
81 (ash (the (signed-byte ,(* cnt 8)) ,res) 8)))
85 ;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*
86 (defmacro read-arg (n)
87 (declare (optimize (speed 0)))
89 `(the (unsigned-byte 8) (read-byte *fasl-input-stream*))
90 `(prepare-for-fast-read-byte *fasl-input-stream*
92 (fast-read-u-integer ,n)
93 (done-with-fast-read-byte)))))
95 ;;; FIXME: This deserves a more descriptive name, and should probably
96 ;;; be implemented as an ordinary function, not a macro.
98 ;;; (for the names: There seem to be only two cases, so it could be
99 ;;; named READ-U-INTEGER-8 and READ-U-INTEGER-32 or something.)
103 ;;; The table is implemented as a simple-vector indexed by the table
104 ;;; offset. We may need to have several, since LOAD can be called
107 ;;; a list of free fop tables for the fasloader
109 ;;; FIXME: Is it really a win to have this permanently bound?
110 ;;; Couldn't we just bind it on entry to LOAD-AS-FASL?
111 (defvar *free-fop-tables* (list (make-array 1000)))
113 ;;; the current fop table
114 (defvar *current-fop-table*)
115 (declaim (simple-vector *current-fop-table*))
117 ;;; the length of the current fop table
118 (defvar *current-fop-table-size*)
119 (declaim (type index *current-fop-table-size*))
121 ;;; the index in the fop-table of the next entry to be used
122 (defvar *current-fop-table-index*)
123 (declaim (type index *current-fop-table-index*))
125 (defun grow-fop-table ()
126 (let* ((new-size (* *current-fop-table-size* 2))
127 (new-table (make-array new-size)))
128 (declare (fixnum new-size) (simple-vector new-table))
129 (replace new-table (the simple-vector *current-fop-table*))
130 (setq *current-fop-table* new-table)
131 (setq *current-fop-table-size* new-size)))
133 (defmacro push-fop-table (thing)
134 (let ((n-index (gensym)))
135 `(let ((,n-index *current-fop-table-index*))
136 (declare (fixnum ,n-index))
137 (when (= ,n-index (the fixnum *current-fop-table-size*))
139 (setq *current-fop-table-index* (1+ ,n-index))
140 (setf (svref *current-fop-table* ,n-index) ,thing))))
144 ;;; (This is in a SIMPLE-VECTOR, but it grows down, since it is
145 ;;; somewhat cheaper to test for overflow that way.)
146 (defvar *fop-stack* (make-array 100))
147 (declaim (simple-vector *fop-stack*))
149 ;;; the index of the most recently pushed item on the fop stack
150 (defvar *fop-stack-pointer* 100)
152 ;;; the current index into the fop stack when we last recursively
154 (defvar *fop-stack-pointer-on-entry*)
155 (declaim (type index *fop-stack-pointer* *fop-stack-pointer-on-entry*))
157 (defun grow-fop-stack ()
158 (let* ((size (length (the simple-vector *fop-stack*)))
159 (new-size (* size 2))
160 (new-stack (make-array new-size)))
161 (declare (fixnum size new-size) (simple-vector new-stack))
162 (replace new-stack (the simple-vector *fop-stack*) :start1 size)
163 (incf *fop-stack-pointer-on-entry* size)
164 (setq *fop-stack-pointer* size)
165 (setq *fop-stack* new-stack)))
167 ;;; Cache information about the fop stack in local variables. Define a
168 ;;; local macro to pop from the stack. Push the result of evaluation
170 (defmacro with-fop-stack (pushp &body forms)
171 (aver (member pushp '(nil t :nope)))
172 (let ((n-stack (gensym))
175 `(let ((,n-stack *fop-stack*)
176 (,n-index *fop-stack-pointer*))
177 (declare (simple-vector ,n-stack) (type index ,n-index))
178 (macrolet ((pop-stack ()
180 (svref ,',n-stack ,',n-index)
182 (call-with-popped-things (fun n)
183 (let ((n-start (gensym)))
184 `(let ((,n-start (+ ,',n-index ,n)))
185 (declare (type index ,n-start))
186 (setq ,',n-index ,n-start)
187 (,fun ,@(make-list n :initial-element
189 (decf ,n-start))))))))
191 `(let ((,n-res (progn ,@forms)))
192 (when (zerop ,n-index)
194 (setq ,n-index *fop-stack-pointer*
195 ,n-stack *fop-stack*))
197 (setq *fop-stack-pointer* ,n-index)
198 (setf (svref ,n-stack ,n-index) ,n-res))
201 (setq *fop-stack-pointer* ,n-index)))))))
205 ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
206 ;;;; suitable modification of the fop table) in GENESIS. Therefore,
207 ;;;; it's needed not only in the target Lisp, but also in the
208 ;;;; cross-compilation host.
210 ;;; a helper function for LOAD-FASL-GROUP
212 ;;; Return true if we successfully read a FASL header from the stream,
213 ;;; or NIL if EOF was hit before anything was read. Signal an error if
214 ;;; we encounter garbage.
215 (defun check-fasl-header (stream)
217 (let ((byte (read-byte stream nil)))
220 ;; Read the string part of the fasl header, or die.
221 (let* ((fhsss *fasl-header-string-start-string*)
222 (fhsss-length (length fhsss)))
223 (unless (= byte (char-code (schar fhsss 0)))
224 (error "illegal first byte in fasl file header"))
225 (do ((byte (read-byte stream) (read-byte stream))
226 (count 1 (1+ count)))
227 ((= byte +fasl-header-string-stop-char-code+)
229 (declare (fixnum byte count))
230 (when (and (< count fhsss-length)
231 (not (eql byte (char-code (schar fhsss count)))))
233 "illegal subsequent (not first) byte in fasl file header"))))
235 ;; Read and validate implementation and version, or die.
236 (let* ((implementation-length (read-arg 4))
237 (implementation-string (make-string implementation-length))
238 (ignore (read-string-as-bytes stream implementation-string))
239 (implementation (keywordicate implementation-string))
240 ;; FIXME: The logic above to read a keyword from the fasl file
241 ;; could probably be shared with the read-a-keyword fop.
242 (version (read-arg 4)))
243 (declare (ignore ignore))
244 (flet ((check-version (variant possible-implementation needed-version)
245 (when (string= possible-implementation implementation)
246 (unless (= version needed-version)
247 (error "~@<~S is in ~A fasl file format version ~D, ~
248 but this version of SBCL uses ~
249 format version ~D.~:@>"
255 (or (check-version "native code"
256 +backend-fasl-file-implementation+
258 (check-version "byte code"
259 (backend-byte-fasl-file-implementation)
261 (error "~S was compiled for implementation ~A, but this is a ~A."
264 +backend-fasl-file-implementation+)))))))
266 ;; Setting this variable gives you a trace of fops as they are loaded and
269 (defvar *show-fops-p* nil)
271 ;;; a helper function for LOAD-AS-FASL
273 ;;; Return true if we successfully load a group from the stream, or
274 ;;; NIL if EOF was encountered while trying to read from the stream.
275 ;;; Dispatch to the right function for each fop. Special-case
276 ;;; FOP-BYTE-PUSH since it is real common.
277 (defun load-fasl-group (stream)
278 (when (check-fasl-header stream)
279 (catch 'fasl-group-end
280 (let ((*current-fop-table-index* 0))
282 (let ((byte (read-byte stream)))
284 ;; Do some debugging output.
287 (let ((ptr *fop-stack-pointer*)
289 (fresh-line *trace-output*)
290 ;; The FOP operations are stack based, so it's sorta
291 ;; logical to display the operand before the operator.
292 ;; ("reverse Polish notation")
293 (unless (= ptr (length stack))
294 (write-char #\space *trace-output*)
295 (prin1 (svref stack ptr) *trace-output*)
296 (terpri *trace-output*))
297 ;; Display the operator.
298 (format *trace-output*
299 "~&~S (#X~X at ~D) (~S)~%"
300 (svref *fop-names* byte)
302 (1- (file-position stream))
303 (svref *fop-functions* byte))))
305 ;; Actually execute the fop.
307 ;; FIXME: This is the special case for FOP-BYTE-PUSH.
308 ;; Benchmark to see whether it's really worth special
309 ;; casing it. If it is, at least express the test in
310 ;; terms of a symbolic name for the FOP-BYTE-PUSH code,
311 ;; not a bare '3' (!). Failing that, remove the special
312 ;; case (and the comment at the head of this function
313 ;; which mentions it).
314 (let ((index *fop-stack-pointer*))
315 (declare (type index index))
318 (setq index *fop-stack-pointer*))
320 (setq *fop-stack-pointer* index)
321 (setf (svref *fop-stack* index)
322 (svref *current-fop-table* (read-byte stream))))
323 (funcall (the function (svref *fop-functions* byte))))))))))
325 (defun load-as-fasl (stream verbose print)
326 ;; KLUDGE: ANSI says it's good to do something with the :PRINT
327 ;; argument to LOAD when we're fasloading a file, but currently we
328 ;; don't. (CMU CL did, but implemented it in a non-ANSI way, and I
329 ;; just disabled that instead of rewriting it.) -- WHN 20000131
330 (declare (ignore print))
332 ;; FIXME: In sbcl-0.6.12.8 the OpenBSD implementation of FILE-LENGTH
333 ;; broke because changed handling of Unix stat(2) stuff couldn't
334 ;; deal with OpenBSD's 64-bit size slot. Once that's fixed, this
335 ;; code can be restored.
337 (when (zerop (file-length stream))
338 (error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
340 (do-load-verbose stream verbose)
341 (let* ((*fasl-input-stream* stream)
342 (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
343 (*current-fop-table-size* (length *current-fop-table*))
344 (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
346 ;; FIXME: This should probably become
347 ;; (LOOP WHILE (LOAD-FASL-GROUP-STREAM))
348 ;; but as a LOOP newbie I don't want to do that until I can
350 (do ((loaded-group (load-fasl-group stream) (load-fasl-group stream)))
351 ((not loaded-group)))
352 (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
353 (push *current-fop-table* *free-fop-tables*)
354 ;; NIL out the stack and table, so that we don't hold onto garbage.
356 ;; FIXME: Couldn't we just get rid of the free fop table pool so
357 ;; that some of this NILing out would go away?
358 (fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
359 (fill *current-fop-table* nil)))
362 ;;; This is used in in target-load and also genesis, using
363 ;;; *COLD-FOREIGN-SYMBOL-TABLE*. All the speculative prefix-adding
364 ;;; code for foreign symbol lookup should be here.
365 (defun find-foreign-symbol-in-table (name table)
367 #!+(or linux freebsd) #("" "ldso_stub__")
368 #!+openbsd #("" "_")))
369 (some (lambda (prefix)
370 (gethash (concatenate 'string prefix name)
376 ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
379 (defvar *fop-counts* (make-array 256 :initial-element 0))
380 (defvar *fop-times* (make-array 256 :initial-element 0))
381 (defvar *print-fops* nil)
383 (defun clear-counts ()
384 (fill (the simple-vector *fop-counts*) 0)
385 (fill (the simple-vector *fop-times*) 0)
388 (defun analyze-counts ()
393 (macrolet ((breakdown (lvar tvar vec)
397 (let ((n (svref ,vec i)))
398 (push (cons (svref *fop-names* i) n) ,lvar)
400 (setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
401 (> (cdr x) (cdr y))))
404 (breakdown counts total-count *fop-counts*)
405 (breakdown times total-time *fop-times*)
406 (format t "Total fop count is ~D~%" total-count)
408 (format t "~30S: ~4D~%" (car c) (cdr c)))
409 (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
411 (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))