0.7.3.12:
[sbcl/lichteblau.git] / src / code / load.lisp
blob9a37fb2dda7dad817e7ef058304c666b2f5896bf
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
3 ;;;; GENESIS)
4 ;;;;
5 ;;;; based on the CMU CL load.lisp code, written by Skef Wholey and
6 ;;;; Rob Maclachlan
8 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; more information.
10 ;;;;
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 ()
24 (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)
36 (when verbose
37 (load-fresh-line)
38 (let ((name #-sb-xc-host (file-name stream-we-are-loading-from)
39 #+sb-xc-host nil))
40 (if name
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
49 ;;; FAST-READ-BYTE.
50 (defmacro fast-read-u-integer (n)
51 (declare (optimize (speed 0)))
52 (do ((res '(fast-read-byte)
53 `(logior (fast-read-byte)
54 (ash ,res 8)))
55 (cnt 1 (1+ cnt)))
56 ((>= cnt n) res)))
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))
61 (n-res (gensym))
62 (n-cnt (gensym)))
63 `(do ((,n-pos 8 (+ ,n-pos 8))
64 (,n-cnt (1- ,n) (1- ,n-cnt))
65 (,n-res
66 (fast-read-byte)
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))
77 ,n-last
78 (logior ,n-last #x-100)))
79 `(logior (fast-read-byte)
80 (ash (the (signed-byte ,(* cnt 8)) ,res) 8)))
81 (cnt 1 (1+ cnt)))
82 ((>= cnt n) res))))
84 ;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*
85 (defmacro read-arg (n)
86 (declare (optimize (speed 0)))
87 (if (= n 1)
88 `(the (unsigned-byte 8) (read-byte *fasl-input-stream*))
89 `(prepare-for-fast-read-byte *fasl-input-stream*
90 (prog1
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.
96 ;;;
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.)
100 ;;;; the fop table
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
104 ;;; recursively.
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*))
137 (grow-fop-table))
138 (setq *current-fop-table-index* (1+ ,n-index))
139 (setf (svref *current-fop-table* ,n-index) ,thing))))
141 ;;;; the fop stack
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
152 ;;; entered LOAD
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
168 ;;; if specified.
169 (defmacro with-fop-stack (pushp &body forms)
170 (aver (member pushp '(nil t :nope)))
171 (let ((n-stack (gensym))
172 (n-index (gensym))
173 (n-res (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 ()
178 `(prog1
179 (svref ,',n-stack ,',n-index)
180 (incf ,',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
187 `(svref ,',n-stack
188 (decf ,n-start))))))))
189 ,(if pushp
190 `(let ((,n-res (progn ,@forms)))
191 (when (zerop ,n-index)
192 (grow-fop-stack)
193 (setq ,n-index *fop-stack-pointer*
194 ,n-stack *fop-stack*))
195 (decf ,n-index)
196 (setq *fop-stack-pointer* ,n-index)
197 (setf (svref ,n-stack ,n-index) ,n-res))
198 `(prog1
199 (progn ,@forms)
200 (setq *fop-stack-pointer* ,n-index)))))))
202 ;;;; LOAD-AS-FASL
203 ;;;;
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)))
217 (when byte
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)))))
231 (error
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.~:@>"
249 stream
250 variant
251 version
252 needed-version))
253 t)))
254 (or (check-version "native code"
255 +backend-fasl-file-implementation+
256 +fasl-file-version+)
257 (error "~S was compiled for implementation ~A, but this is a ~A."
258 stream
259 implementation
260 +backend-fasl-file-implementation+)))))))
262 ;; Setting this variable gives you a trace of fops as they are loaded and
263 ;; executed.
264 #!+sb-show
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))
277 (loop
278 (let ((byte (read-byte stream)))
280 ;; Do some debugging output.
281 #!+sb-show
282 (when *show-fops-p*
283 (let ((ptr *fop-stack-pointer*)
284 (stack *fop-stack*))
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)
297 byte
298 (1- (file-position stream))
299 (svref *fop-funs* byte))))
301 ;; Actually execute the fop.
302 (if (eql byte 3)
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))
312 (when (zerop index)
313 (grow-fop-stack)
314 (setq index *fop-stack-pointer*))
315 (decf index)
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*))
334 (unwind-protect
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
338 ;; test it.
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)
355 (let ((prefixes
356 #!+(or linux freebsd) #("" "ldso_stub__")
357 #!+openbsd #("")
358 #!+sunos #("" "ldso_stub__")))
359 (declare (notinline some)) ; to suppress bug 117 bogowarning
360 (some (lambda (prefix)
361 (gethash (concatenate 'string prefix name)
362 table
363 nil))
364 prefixes)))
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 ()
380 (let ((counts ())
381 (total-count 0)
382 (times ())
383 (total-time 0))
384 (macrolet ((breakdown (lvar tvar vec)
385 `(progn
386 (dotimes (i 255)
387 (declare (fixnum i))
388 (let ((n (svref ,vec i)))
389 (push (cons (svref *fop-names* i) n) ,lvar)
390 (incf ,tvar n)))
391 (setq ,lvar (subseq (sort ,lvar (lambda (x y)
392 (> (cdr x) (cdr y))))
393 0 10)))))
395 (breakdown counts total-count *fop-counts*)
396 (breakdown times total-time *fop-times*)
397 (format t "Total fop count is ~D~%" total-count)
398 (dolist (c counts)
399 (format t "~30S: ~4D~%" (car c) (cdr c)))
400 (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
401 (dolist (m times)
402 (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))