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
34 ;;; we're loading from STREAM-WE-ARE-LOADING-FROM.
35 (defun maybe-announce-load (stream-we-are-loading-from verbose
)
38 (let ((name #-sb-xc-host
(file-name stream-we-are-loading-from
)
41 (format t
"loading ~S~%" name
)
42 (format t
"loading stuff from ~S~%" stream-we-are-loading-from
)))))
44 ;;;; utilities for reading from fasl files
46 #!-sb-fluid
(declaim (inline read-byte
))
48 ;;; This expands into code to read an N-byte unsigned integer using
50 (defmacro fast-read-u-integer
(n)
51 (declare (optimize (speed 0)))
52 (do ((res '(fast-read-byte)
53 `(logior (fast-read-byte)
58 ;;; like FAST-READ-U-INTEGER, but the size may be determined at run time
59 (defmacro fast-read-var-u-integer
(n)
60 (let ((n-pos (gensym))
63 `(do ((,n-pos
8 (+ ,n-pos
8))
64 (,n-cnt
(1- ,n
) (1- ,n-cnt
))
67 (dpb (fast-read-byte) (byte 8 ,n-pos
) ,n-res
)))
68 ((zerop ,n-cnt
) ,n-res
)
69 (declare (type index
,n-pos
,n-cnt
)))))
71 ;;; Read a signed integer.
72 (defmacro fast-read-s-integer
(n)
73 (declare (optimize (speed 0)))
74 (let ((n-last (gensym)))
75 (do ((res `(let ((,n-last
(fast-read-byte)))
76 (if (zerop (logand ,n-last
#x80
))
78 (logior ,n-last
#x-100
)))
79 `(logior (fast-read-byte)
80 (ash (the (signed-byte ,(* cnt
8)) ,res
) 8)))
84 ;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*
85 (defmacro read-arg
(n)
86 (declare (optimize (speed 0)))
88 `(the (unsigned-byte 8) (read-byte *fasl-input-stream
*))
89 `(prepare-for-fast-read-byte *fasl-input-stream
*
91 (fast-read-u-integer ,n
)
92 (done-with-fast-read-byte)))))
94 ;;; FIXME: This deserves a more descriptive name, and should probably
95 ;;; be implemented as an ordinary function, not a macro.
97 ;;; (for the names: There seem to be only two cases, so it could be
98 ;;; named READ-U-INTEGER-8 and READ-U-INTEGER-32 or something.)
102 ;;; The table is implemented as a simple-vector indexed by the table
103 ;;; offset. We may need to have several, since LOAD can be called
106 ;;; a list of free fop tables for the fasloader
108 ;;; FIXME: Is it really a win to have this permanently bound?
109 ;;; Couldn't we just bind it on entry to LOAD-AS-FASL?
110 (defvar *free-fop-tables
* (list (make-array 1000)))
112 ;;; the current fop table
113 (defvar *current-fop-table
*)
114 (declaim (simple-vector *current-fop-table
*))
116 ;;; the length of the current fop table
117 (defvar *current-fop-table-size
*)
118 (declaim (type index
*current-fop-table-size
*))
120 ;;; the index in the fop-table of the next entry to be used
121 (defvar *current-fop-table-index
*)
122 (declaim (type index
*current-fop-table-index
*))
124 (defun grow-fop-table ()
125 (let* ((new-size (* *current-fop-table-size
* 2))
126 (new-table (make-array new-size
)))
127 (declare (fixnum new-size
) (simple-vector new-table
))
128 (replace new-table
(the simple-vector
*current-fop-table
*))
129 (setq *current-fop-table
* new-table
)
130 (setq *current-fop-table-size
* new-size
)))
132 (defmacro push-fop-table
(thing)
133 (let ((n-index (gensym)))
134 `(let ((,n-index
*current-fop-table-index
*))
135 (declare (fixnum ,n-index
))
136 (when (= ,n-index
(the fixnum
*current-fop-table-size
*))
138 (setq *current-fop-table-index
* (1+ ,n-index
))
139 (setf (svref *current-fop-table
* ,n-index
) ,thing
))))
143 ;;; (This is in a SIMPLE-VECTOR, but it grows down, since it is
144 ;;; somewhat cheaper to test for overflow that way.)
145 (defvar *fop-stack
* (make-array 100))
146 (declaim (simple-vector *fop-stack
*))
148 ;;; the index of the most recently pushed item on the fop stack
149 (defvar *fop-stack-pointer
* 100)
151 ;;; the current index into the fop stack when we last recursively
153 (defvar *fop-stack-pointer-on-entry
*)
154 (declaim (type index
*fop-stack-pointer
* *fop-stack-pointer-on-entry
*))
156 (defun grow-fop-stack ()
157 (let* ((size (length (the simple-vector
*fop-stack
*)))
158 (new-size (* size
2))
159 (new-stack (make-array new-size
)))
160 (declare (fixnum size new-size
) (simple-vector new-stack
))
161 (replace new-stack
(the simple-vector
*fop-stack
*) :start1 size
)
162 (incf *fop-stack-pointer-on-entry
* size
)
163 (setq *fop-stack-pointer
* size
)
164 (setq *fop-stack
* new-stack
)))
166 ;;; Cache information about the fop stack in local variables. Define a
167 ;;; local macro to pop from the stack. Push the result of evaluation
169 (defmacro with-fop-stack
(pushp &body forms
)
170 (aver (member pushp
'(nil t
:nope
)))
171 (let ((n-stack (gensym))
174 `(let ((,n-stack
*fop-stack
*)
175 (,n-index
*fop-stack-pointer
*))
176 (declare (simple-vector ,n-stack
) (type index
,n-index
))
177 (macrolet ((pop-stack ()
179 (svref ,',n-stack
,',n-index
)
181 (call-with-popped-things (fun n
)
182 (let ((n-start (gensym)))
183 `(let ((,n-start
(+ ,',n-index
,n
)))
184 (declare (type index
,n-start
))
185 (setq ,',n-index
,n-start
)
186 (,fun
,@(make-list n
:initial-element
188 (decf ,n-start
))))))))
190 `(let ((,n-res
(progn ,@forms
)))
191 (when (zerop ,n-index
)
193 (setq ,n-index
*fop-stack-pointer
*
194 ,n-stack
*fop-stack
*))
196 (setq *fop-stack-pointer
* ,n-index
)
197 (setf (svref ,n-stack
,n-index
) ,n-res
))
200 (setq *fop-stack-pointer
* ,n-index
)))))))
204 ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
205 ;;;; suitable modification of the fop table) in GENESIS. Therefore,
206 ;;;; it's needed not only in the target Lisp, but also in the
207 ;;;; cross-compilation host.
209 ;;; a helper function for LOAD-FASL-GROUP
211 ;;; Return true if we successfully read a FASL header from the stream,
212 ;;; or NIL if EOF was hit before anything was read. Signal an error if
213 ;;; we encounter garbage.
214 (defun check-fasl-header (stream)
216 (let ((byte (read-byte stream nil
)))
219 ;; Read the string part of the fasl header, or die.
220 (let* ((fhsss *fasl-header-string-start-string
*)
221 (fhsss-length (length fhsss
)))
222 (unless (= byte
(char-code (schar fhsss
0)))
223 (error "illegal first byte in fasl file header"))
224 (do ((byte (read-byte stream
) (read-byte stream
))
225 (count 1 (1+ count
)))
226 ((= byte
+fasl-header-string-stop-char-code
+)
228 (declare (fixnum byte count
))
229 (when (and (< count fhsss-length
)
230 (not (eql byte
(char-code (schar fhsss count
)))))
232 "illegal subsequent (not first) byte in fasl file header"))))
234 ;; Read and validate implementation and version, or die.
235 (let* ((implementation-length (read-arg 4))
236 (implementation-string (make-string implementation-length
))
237 (ignore (read-string-as-bytes stream implementation-string
))
238 (implementation (keywordicate implementation-string
))
239 ;; FIXME: The logic above to read a keyword from the fasl file
240 ;; could probably be shared with the read-a-keyword fop.
241 (version (read-arg 4)))
242 (declare (ignore ignore
))
243 (flet ((check-version (variant possible-implementation needed-version
)
244 (when (string= possible-implementation implementation
)
245 (unless (= version needed-version
)
246 (error "~@<~S is in ~A fasl file format version ~W, ~
247 but this version of SBCL uses ~
248 format version ~W.~:@>"
254 (or (check-version "native code"
255 +backend-fasl-file-implementation
+
257 (error "~S was compiled for implementation ~A, but this is a ~A."
260 +backend-fasl-file-implementation
+)))))))
262 ;; Setting this variable gives you a trace of fops as they are loaded and
265 (defvar *show-fops-p
* nil
)
267 ;;; a helper function for LOAD-AS-FASL
269 ;;; Return true if we successfully load a group from the stream, or
270 ;;; NIL if EOF was encountered while trying to read from the stream.
271 ;;; Dispatch to the right function for each fop. Special-case
272 ;;; FOP-BYTE-PUSH since it is real common.
273 (defun load-fasl-group (stream)
274 (when (check-fasl-header stream
)
275 (catch 'fasl-group-end
276 (let ((*current-fop-table-index
* 0))
278 (let ((byte (read-byte stream
)))
280 ;; Do some debugging output.
283 (let ((ptr *fop-stack-pointer
*)
285 (fresh-line *trace-output
*)
286 ;; The FOP operations are stack based, so it's sorta
287 ;; logical to display the operand before the operator.
288 ;; ("reverse Polish notation")
289 (unless (= ptr
(length stack
))
290 (write-char #\space
*trace-output
*)
291 (prin1 (svref stack ptr
) *trace-output
*)
292 (terpri *trace-output
*))
293 ;; Display the operator.
294 (format *trace-output
*
295 "~&~S (#X~X at ~D) (~S)~%"
296 (svref *fop-names
* byte
)
298 (1- (file-position stream
))
299 (svref *fop-funs
* byte
))))
301 ;; Actually execute the fop.
303 ;; FIXME: This is the special case for FOP-BYTE-PUSH.
304 ;; Benchmark to see whether it's really worth special
305 ;; casing it. If it is, at least express the test in
306 ;; terms of a symbolic name for the FOP-BYTE-PUSH code,
307 ;; not a bare '3' (!). Failing that, remove the special
308 ;; case (and the comment at the head of this function
309 ;; which mentions it).
310 (let ((index *fop-stack-pointer
*))
311 (declare (type index index
))
314 (setq index
*fop-stack-pointer
*))
316 (setq *fop-stack-pointer
* index
)
317 (setf (svref *fop-stack
* index
)
318 (svref *current-fop-table
* (read-byte stream
))))
319 (funcall (the function
(svref *fop-funs
* byte
))))))))))
321 (defun load-as-fasl (stream verbose print
)
322 ;; KLUDGE: ANSI says it's good to do something with the :PRINT
323 ;; argument to LOAD when we're fasloading a file, but currently we
324 ;; don't. (CMU CL did, but implemented it in a non-ANSI way, and I
325 ;; just disabled that instead of rewriting it.) -- WHN 20000131
326 (declare (ignore print
))
327 (when (zerop (file-length stream
))
328 (error "attempt to load an empty FASL file:~% ~S" (namestring stream
)))
329 (maybe-announce-load stream verbose
)
330 (let* ((*fasl-input-stream
* stream
)
331 (*current-fop-table
* (or (pop *free-fop-tables
*) (make-array 1000)))
332 (*current-fop-table-size
* (length *current-fop-table
*))
333 (*fop-stack-pointer-on-entry
* *fop-stack-pointer
*))
335 ;; FIXME: This should probably become
336 ;; (LOOP WHILE (LOAD-FASL-GROUP-STREAM))
337 ;; but as a LOOP newbie I don't want to do that until I can
339 (do ((loaded-group (load-fasl-group stream
) (load-fasl-group stream
)))
340 ((not loaded-group
)))
341 (setq *fop-stack-pointer
* *fop-stack-pointer-on-entry
*)
342 (push *current-fop-table
* *free-fop-tables
*)
343 ;; NIL out the stack and table, so that we don't hold onto garbage.
345 ;; FIXME: Couldn't we just get rid of the free fop table pool so
346 ;; that some of this NILing out would go away?
347 (fill *fop-stack
* nil
:end
*fop-stack-pointer-on-entry
*)
348 (fill *current-fop-table
* nil
)))
351 ;;; This is used in in target-load and also genesis, using
352 ;;; *COLD-FOREIGN-SYMBOL-TABLE*. All the speculative prefix-adding
353 ;;; code for foreign symbol lookup should be here.
354 (defun find-foreign-symbol-in-table (name table
)
356 #!+(or linux freebsd
) #("" "ldso_stub__")
358 #!+sunos
#("" "ldso_stub__")))
359 (declare (notinline some
)) ; to suppress bug 117 bogowarning
360 (some (lambda (prefix)
361 (gethash (concatenate 'string prefix name
)
367 ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
370 (defvar *fop-counts
* (make-array 256 :initial-element
0))
371 (defvar *fop-times
* (make-array 256 :initial-element
0))
372 (defvar *print-fops
* nil
)
374 (defun clear-counts ()
375 (fill (the simple-vector
*fop-counts
*) 0)
376 (fill (the simple-vector
*fop-times
*) 0)
379 (defun analyze-counts ()
384 (macrolet ((breakdown (lvar tvar vec
)
388 (let ((n (svref ,vec i
)))
389 (push (cons (svref *fop-names
* i
) n
) ,lvar
)
391 (setq ,lvar
(subseq (sort ,lvar
(lambda (x y
)
392 (> (cdr x
) (cdr y
))))
395 (breakdown counts total-count
*fop-counts
*)
396 (breakdown times total-time
*fop-times
*)
397 (format t
"Total fop count is ~D~%" total-count
)
399 (format t
"~30S: ~4D~%" (car c
) (cdr c
)))
400 (format t
"~%Total fop time is ~D~%" (/ (float total-time
) 60.0))
402 (format t
"~30S: ~6,2F~%" (car m
) (/ (float (cdr m
)) 60.0))))))