[3d19a6]: src / code / load.lisp Maximize Restore History

Download this file

load.lisp    451 lines (402 with data), 16.6 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
;;;; parts of the loader which make sense in the cross-compilation
;;;; host (and which are useful in the host, because they're used by
;;;; GENESIS)
;;;;
;;;; based on the CMU CL load.lisp code, written by Skef Wholey and
;;;; Rob Maclachlan
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!FASL")
;;;; There looks to be an exciting amount of state being modified
;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess
;;;; around deciding how to thread-safetify it. So we use a Big Lock.
;;;; Because this code is mutually recursive with the compiler, we use
;;;; the *big-compiler-lock*
;;;; miscellaneous load utilities
;;; Output the current number of semicolons after a fresh-line.
;;; FIXME: non-mnemonic name
(defun load-fresh-line ()
(fresh-line)
(let ((semicolons ";;;;;;;;;;;;;;;;"))
(do ((count *load-depth* (- count (length semicolons))))
((< count (length semicolons))
(write-string semicolons *standard-output* :end count))
(declare (fixnum count))
(write-string semicolons))
(write-char #\space)))
;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how
;;; we're loading from STREAM-WE-ARE-LOADING-FROM.
(defun maybe-announce-load (stream-we-are-loading-from verbose)
(when verbose
(load-fresh-line)
(let ((name #-sb-xc-host (file-name stream-we-are-loading-from)
#+sb-xc-host nil))
(if name
(format t "loading ~S~%" name)
(format t "loading stuff from ~S~%" stream-we-are-loading-from)))))
;;;; utilities for reading from fasl files
#!-sb-fluid (declaim (inline read-byte))
;;; This expands into code to read an N-byte unsigned integer using
;;; FAST-READ-BYTE.
(defmacro fast-read-u-integer (n)
(declare (optimize (speed 0)))
(do ((res '(fast-read-byte)
`(logior (fast-read-byte)
(ash ,res 8)))
(cnt 1 (1+ cnt)))
((>= cnt n) res)))
;;; like FAST-READ-U-INTEGER, but the size may be determined at run time
(defmacro fast-read-var-u-integer (n)
(let ((n-pos (gensym))
(n-res (gensym))
(n-cnt (gensym)))
`(do ((,n-pos 8 (+ ,n-pos 8))
(,n-cnt (1- ,n) (1- ,n-cnt))
(,n-res
(fast-read-byte)
(dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
((zerop ,n-cnt) ,n-res)
(declare (type index ,n-pos ,n-cnt)))))
;;; Read a signed integer.
(defmacro fast-read-s-integer (n)
(declare (optimize (speed 0)))
(let ((n-last (gensym)))
(do ((res `(let ((,n-last (fast-read-byte)))
(if (zerop (logand ,n-last #x80))
,n-last
(logior ,n-last #x-100)))
`(logior (fast-read-byte)
(ash (the (signed-byte ,(* cnt 8)) ,res) 8)))
(cnt 1 (1+ cnt)))
((>= cnt n) res))))
;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*
(defmacro read-arg (n)
(declare (optimize (speed 0)))
(if (= n 1)
`(the (unsigned-byte 8) (read-byte *fasl-input-stream*))
`(prepare-for-fast-read-byte *fasl-input-stream*
(prog1
(fast-read-u-integer ,n)
(done-with-fast-read-byte)))))
;;; FIXME: This deserves a more descriptive name, and should probably
;;; be implemented as an ordinary function, not a macro.
;;;
;;; (for the names: There seem to be only two cases, so it could be
;;; named READ-U-INTEGER-8 and READ-U-INTEGER-32 or something.)
;;;; the fop table
;;; The table is implemented as a simple-vector indexed by the table
;;; offset. We may need to have several, since LOAD can be called
;;; recursively.
;;; a list of free fop tables for the fasloader
;;;
;;; FIXME: Is it really a win to have this permanently bound?
;;; Couldn't we just bind it on entry to LOAD-AS-FASL?
(defvar *free-fop-tables* (list (make-array 1000)))
;;; the current fop table
(defvar *current-fop-table*)
(declaim (simple-vector *current-fop-table*))
;;; the length of the current fop table
(defvar *current-fop-table-size*)
(declaim (type index *current-fop-table-size*))
;;; the index in the fop-table of the next entry to be used
(defvar *current-fop-table-index*)
(declaim (type index *current-fop-table-index*))
(defun grow-fop-table ()
(let* ((new-size (* *current-fop-table-size* 2))
(new-table (make-array new-size)))
(declare (fixnum new-size) (simple-vector new-table))
(replace new-table (the simple-vector *current-fop-table*))
(setq *current-fop-table* new-table)
(setq *current-fop-table-size* new-size)))
(defmacro push-fop-table (thing)
(let ((n-index (gensym)))
`(let ((,n-index *current-fop-table-index*))
(declare (fixnum ,n-index))
(when (= ,n-index (the fixnum *current-fop-table-size*))
(grow-fop-table))
(setq *current-fop-table-index* (1+ ,n-index))
(setf (svref *current-fop-table* ,n-index) ,thing))))
;;;; the fop stack
;;; (This is to be bound by LOAD to an adjustable (VECTOR T) with
;;; FILL-POINTER, for use as a stack with VECTOR-PUSH-EXTEND.)
(defvar *fop-stack*)
(declaim (type (vector t) *fop-stack*))
;;; Cache information about the fop stack in local variables. Define a
;;; local macro to pop from the stack. Push the result of evaluation
;;; if PUSHP.
(defmacro with-fop-stack (pushp &body forms)
(aver (member pushp '(nil t :nope)))
(with-unique-names (fop-stack)
`(let ((,fop-stack *fop-stack*))
(declare (type (vector t) ,fop-stack))
(macrolet ((pop-stack ()
`(vector-pop ,',fop-stack))
(call-with-popped-args (fun n)
`(%call-with-popped-args ,fun ,n ,',fop-stack)))
,(if pushp
`(vector-push-extend (progn ,@forms) ,fop-stack)
`(progn ,@forms))))))
;;; Call FUN with N arguments popped from STACK.
(defmacro %call-with-popped-args (fun n stack)
;; N's integer value must be known at macroexpansion time.
(declare (type index n))
(with-unique-names (n-stack old-length new-length)
(let ((argtmps (make-gensym-list n)))
`(let* ((,n-stack ,stack)
(,old-length (fill-pointer ,n-stack))
(,new-length (- ,old-length ,n))
,@(loop for i from 0 below n collecting
`(,(nth i argtmps)
(aref ,n-stack (+ ,new-length ,i)))))
(declare (type (vector t) ,n-stack))
(setf (fill-pointer ,n-stack) ,new-length)
;; (For some applications it might be appropriate to FILL the
;; popped area with NIL here, to avoid holding onto garbage. For
;; sbcl-0.8.7.something, though, it shouldn't matter, because
;; we're using this only to pop stuff off *FOP-STACK*, and the
;; entire *FOP-STACK* can be GCed as soon as LOAD returns.)
(,fun ,@argtmps)))))
;;;; Conditions signalled on invalid fasls (wrong fasl version, etc),
;;;; so that user code (esp. ASDF) can reasonably handle attempts to
;;;; load such fasls by recompiling them, etc. For simplicity's sake
;;;; make only condition INVALID-FASL part of the public interface,
;;;; and keep the guts internal.
(define-condition invalid-fasl (error)
((stream :reader invalid-fasl-stream :initarg :stream)
(expected :reader invalid-fasl-expected :initarg :expected))
(:report
(lambda (condition stream)
(format stream "~S is an invalid fasl file."
(invalid-fasl-stream condition)))))
(define-condition invalid-fasl-header (invalid-fasl)
((byte :reader invalid-fasl-byte :initarg :byte)
(byte-nr :reader invalid-fasl-byte-nr :initarg :byte-nr))
(:report
(lambda (condition stream)
(format stream "~@<~S contains an illegal byte in the FASL header at ~
position ~A: Expected ~A, got ~A.~:@>"
(invalid-fasl-stream condition)
(invalid-fasl-byte-nr condition)
(invalid-fasl-byte condition)
(invalid-fasl-expected condition)))))
(define-condition invalid-fasl-version (invalid-fasl)
((variant :reader invalid-fasl-variant :initarg :variant)
(version :reader invalid-fasl-version :initarg :version))
(:report
(lambda (condition stream)
(format stream "~@<~S is in ~A fasl file format version ~W, ~
but this version of SBCL uses format version ~W.~:@>"
(invalid-fasl-stream condition)
(invalid-fasl-variant condition)
(invalid-fasl-version condition)
(invalid-fasl-expected condition)))))
(define-condition invalid-fasl-implementation (invalid-fasl)
((implementation :reader invalid-fasl-implementation
:initarg :implementation))
(:report
(lambda (condition stream)
(format stream "~S was compiled for implementation ~A, but this is a ~A."
(invalid-fasl-stream condition)
(invalid-fasl-implementation condition)
(invalid-fasl-expected condition)))))
(define-condition invalid-fasl-features (invalid-fasl)
((potential-features :reader invalid-fasl-potential-features
:initarg :potential-features)
(features :reader invalid-fasl-features :initarg :features))
(:report
(lambda (condition stream)
(format stream "~@<incompatible ~S in fasl file ~S: ~2I~_~
Of features affecting binary compatibility, ~4I~_~S~2I~_~
the fasl has ~4I~_~A,~2I~_~
while the runtime expects ~4I~_~A.~:>"
'*features*
(invalid-fasl-stream condition)
(invalid-fasl-potential-features condition)
(invalid-fasl-features condition)
(invalid-fasl-expected condition)))))
;;;; LOAD-AS-FASL
;;;;
;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
;;;; suitable modification of the fop table) in GENESIS. Therefore,
;;;; it's needed not only in the target Lisp, but also in the
;;;; cross-compilation host.
;;; a helper function for LOAD-FASL-GROUP
;;;
;;; Return true if we successfully read a FASL header from the stream,
;;; or NIL if EOF was hit before anything was read. Signal an error if
;;; we encounter garbage.
(defun check-fasl-header (stream)
(let ((byte (read-byte stream nil)))
(when byte
;; Read and validate constant string prefix in fasl header.
(let* ((fhsss *fasl-header-string-start-string*)
(fhsss-length (length fhsss)))
(unless (= byte (char-code (schar fhsss 0)))
(error 'invalid-fasl-header
:stream stream
:first-byte-p t
:byte byte
:expected (char-code (schar fhsss 0))))
(do ((byte (read-byte stream) (read-byte stream))
(count 1 (1+ count)))
((= byte +fasl-header-string-stop-char-code+)
t)
(declare (fixnum byte count))
(when (and (< count fhsss-length)
(not (eql byte (char-code (schar fhsss count)))))
(error 'invalid-fasl-header
:stream stream
:byte-nr count
:byte byte
:expected (char-code (schar fhsss count))))))
;; Read and validate version-specific compatibility stuff.
(flet ((string-from-stream ()
(let* ((length (read-arg 4))
(result (make-string length)))
(read-string-as-bytes stream result)
result)))
;; Read and validate implementation and version.
(let* ((implementation (keywordicate (string-from-stream)))
;; FIXME: The logic above to read a keyword from the fasl file
;; could probably be shared with the read-a-keyword fop.
(version (read-arg 4)))
(flet ((check-version (variant
possible-implementation
needed-version)
(when (string= possible-implementation implementation)
(or (= version needed-version)
(error 'invalid-fasl-version
;; :error :wrong-version
:stream stream
:variant variant
:version version
:expected needed-version)))))
(or (check-version "native code"
+backend-fasl-file-implementation+
+fasl-file-version+)
(error 'invalid-fasl-implementation
:stream stream
:implementation implementation
:expected +backend-fasl-file-implementation+))))
;; Read and validate *FEATURES* which affect binary compatibility.
(let ((faff-in-this-file (string-from-stream)))
(unless (string= faff-in-this-file *features-affecting-fasl-format*)
(error 'invalid-fasl-features
:stream stream
:potential-features *features-potentially-affecting-fasl-format*
:expected *features-affecting-fasl-format*
:features faff-in-this-file)))
;; success
t))))
;; Setting this variable gives you a trace of fops as they are loaded and
;; executed.
#!+sb-show
(defvar *show-fops-p* nil)
;;; a helper function for LOAD-AS-FASL
;;;
;;; Return true if we successfully load a group from the stream, or
;;; NIL if EOF was encountered while trying to read from the stream.
;;; Dispatch to the right function for each fop.
(defun load-fasl-group (stream)
(when (check-fasl-header stream)
(catch 'fasl-group-end
(let ((*current-fop-table-index* 0))
(loop
(let ((byte (read-byte stream)))
;; Do some debugging output.
#!+sb-show
(when *show-fops-p*
(let* ((stack *fop-stack*)
(ptr (1- (fill-pointer *fop-stack*))))
(fresh-line *trace-output*)
;; The FOP operations are stack based, so it's sorta
;; logical to display the operand before the operator.
;; ("reverse Polish notation")
(unless (= ptr -1)
(write-char #\space *trace-output*)
(prin1 (aref stack ptr) *trace-output*)
(terpri *trace-output*))
;; Display the operator.
(format *trace-output*
"~&~S (#X~X at ~D) (~S)~%"
(aref *fop-names* byte)
byte
(1- (file-position stream))
(svref *fop-funs* byte))))
;; Actually execute the fop.
(funcall (the function (svref *fop-funs* byte)))))))))
(defun load-as-fasl (stream verbose print)
;; KLUDGE: ANSI says it's good to do something with the :PRINT
;; argument to LOAD when we're fasloading a file, but currently we
;; don't. (CMU CL did, but implemented it in a non-ANSI way, and I
;; just disabled that instead of rewriting it.) -- WHN 20000131
(declare (ignore print))
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
(maybe-announce-load stream verbose)
(sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*)
(let* ((*fasl-input-stream* stream)
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
(*current-fop-table-size* (length *current-fop-table*))
(*fop-stack* (make-array 100 :fill-pointer 0 :adjustable t)))
(unwind-protect
(loop while (load-fasl-group stream))
(push *current-fop-table* *free-fop-tables*)
;; NIL out the table, so that we don't hold onto garbage.
;;
;; FIXME: Could we just get rid of the free fop table pool so
;; that this would go away?
(fill *current-fop-table* nil))))
t)
;;; This is used in in target-load and also genesis, using
;;; *COLD-FOREIGN-SYMBOL-TABLE*. All the speculative prefix-adding
;;; code for foreign symbol lookup should be here.
(defun find-foreign-symbol-in-table (name table)
(let ((prefixes
#!+(or osf1 sunos linux freebsd netbsd darwin) #("" "ldso_stub__")
#!+openbsd #("")))
(declare (notinline some)) ; to suppress bug 117 bogowarning
(some (lambda (prefix)
(gethash (concatenate 'string prefix name)
table
nil))
prefixes)))
;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
#|
(defvar *fop-counts* (make-array 256 :initial-element 0))
(defvar *fop-times* (make-array 256 :initial-element 0))
(defvar *print-fops* nil)
(defun clear-counts ()
(fill (the simple-vector *fop-counts*) 0)
(fill (the simple-vector *fop-times*) 0)
t)
(defun analyze-counts ()
(let ((counts ())
(total-count 0)
(times ())
(total-time 0))
(macrolet ((breakdown (lvar tvar vec)
`(progn
(dotimes (i 255)
(declare (fixnum i))
(let ((n (svref ,vec i)))
(push (cons (svref *fop-names* i) n) ,lvar)
(incf ,tvar n)))
(setq ,lvar (subseq (sort ,lvar (lambda (x y)
(> (cdr x) (cdr y))))
0 10)))))
(breakdown counts total-count *fop-counts*)
(breakdown times total-time *fop-times*)
(format t "Total fop count is ~D~%" total-count)
(dolist (c counts)
(format t "~30S: ~4D~%" (car c) (cdr c)))
(format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
(dolist (m times)
(format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))
|#