Newer
Older
;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.28 1991/03/23 17:38:18 wlott Exp $")
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.28 1991/03/23 17:38:18 wlott Exp $
;;; Loader for Spice Lisp.
;;; Written by Skef Wholey and Rob MacLachlan.
;;;
(in-package "LISP")
(export '(load *load-verbose*))
(in-package "EXTENSIONS")
(export '*load-if-source-newer*)
(in-package "LISP")
;;;; Random state variables:
(defvar *load-verbose* ()
"The default for the :Verbose argument to Load.")
(defvar *load-print-stuff* ()
"True if we're gonna mumble about what we're loading.")
(defvar *fasl-file* ()
"The fasl file we're reading from.")
(defvar *current-code-format*
"The code format that we think we are loading.")
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
(defvar *load-if-source-newer* :load-object
"The value of *load-if-source-newer* determines what happens when the
source file is newer than the object file. The possible values are:
:load-object - load object file (default), :load-source - load the source
file, :compile - compile the source and then load the object file, or
:query - ask the user if he wants to load the source or object file.")
;;;; 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.
(defvar *free-fop-tables* (list (make-array 1000))
"List of free fop tables for the fasloader.")
(defvar *current-fop-table* ()
"The current fop table.")
(defvar *current-fop-table-size* ()
"The length of the current fop table.")
(defvar *current-fop-table-index* ()
"Index in the fop-table of the next entry to be used.")
(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-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:
;;;
;;; The is also in a simple-vector, but it grows down, since it is somewhat
;;; cheaper to test for overflow that way.
;;;
(defvar *fop-stack* (make-array 100)
"The fop stack (we only need one!).")
(defvar *fop-stack-pointer* 100
"The index of the most recently pushed item on the fop-stack.")
(defvar *fop-stack-pointer-on-entry* ()
"The current index into the fop stack when we last recursively entered LOAD.")
(defun grow-fop-stack ()
(let* ((size (length (the simple-vector *fop-stack*)))
(new-size (* size 2))
(new-stack (make-array new-size)))
(declare (fixnum size new-size) (simple-vector new-stack))
(replace new-stack (the simple-vector *fop-stack*) :start1 size)
(incf *fop-stack-pointer-on-entry* size)
(setq *fop-stack-pointer* size)
(setq *fop-stack* new-stack)))
;;; With-Fop-Stack -- Internal
;;;
;;; Cache information about the fop-stack in local variables. Define
;;; a local macro to pop from the stack. Push the result of evaluation if
;;; specified.
;;;
(defmacro with-fop-stack (pushp &body forms)
(let ((n-stack (gensym))
(n-index (gensym))
(n-res (gensym)))
`(let ((,n-stack *fop-stack*)
(,n-index *fop-stack-pointer*))
(declare (simple-vector ,n-stack) (fixnum ,n-index))
(macrolet ((pop-stack ()
`(prog1
(svref ,',n-stack ,',n-index)
(setq ,',n-index (1+ ,',n-index))))
(call-with-popped-things (fun n)
(let ((n-start (gensym)))
`(let ((,n-start (+ ,',n-index ,n)))
(setq ,',n-index ,n-start)
(,fun ,@(make-list n :initial-element
`(svref ,',n-stack
(decf ,n-start))))))))
,(if pushp
`(let ((,n-res (progn ,@forms)))
(when (zerop ,n-index)
(grow-fop-stack)
(setq ,n-index *fop-stack-pointer*
,n-stack *fop-stack*))
(decf ,n-index)
(setq *fop-stack-pointer* ,n-index)
(setf (svref ,n-stack ,n-index) ,n-res))
`(prog1
(progn ,@forms)
(setq *fop-stack-pointer* ,n-index)))))))
;;; FOP database:
(defvar fop-codes (make-array 256)
"Vector indexed by a FaslOP that yields the FOP's name.")
(defvar fop-functions
(make-array 256 :initial-element #'(lambda () (error "Losing FOP!")))
"Vector indexed by a FaslOP that yields a function of 0 arguments which
will perform the operation.")
;;; Define-FOP -- Internal
;;;
;;; Defines Name as a fasl operation, with op-code op. If pushp is :nope,
;;; the the body neither pushes or pops the fop stack. If it is nil, then
;;; the body may pop, but the result is ignored. If it is true, the the result
;;; is pushed on the stack.
;;;
(defmacro define-fop ((name op &optional (pushp t)) &rest forms)
`(progn
(defun ,name ()
,(if (eq pushp :nope)
`(progn ,@forms)
`(with-fop-stack ,pushp ,@forms)))
(setf (svref fop-codes ,op) ',name)
(setf (get ',name 'fop-code) ,op)
(setf (svref fop-functions ,op) #',name)))
;;; Clone-Fop -- Internal
;;;
;;; Defines a pair of fops which are identical except in that one reads
;;; a four byte argument and the other reads a one byte argument. The
;;; argument can be accessed by using the Clone-Arg macro.
;;;
(defmacro clone-fop ((name op &optional (pushp t))
(small-name small-op) &rest forms)
`(progn
(macrolet ((clone-arg () '(read-arg 4)))
(define-fop (,name ,op ,pushp) ,@forms))
(macrolet ((clone-arg () '(read-arg 1)))
(define-fop (,small-name ,small-op ,pushp) ,@forms))))
;;;; Utilities for reading from the fasl file.
(proclaim '(inline read-byte))
;;; Fast-Read-U-Integer -- Internal
;;;
;;; Expands into code to read an N-byte unsigned integer using
;;; fast-read-byte.
;;;
(defmacro fast-read-u-integer (n)
(do ((res '(fast-read-byte)
`(logior (fast-read-byte)
(ash ,res 8)))
(cnt 1 (1+ cnt)))
((>= cnt n) res)))
;;; Fast-Read-Variable-U-Integer -- Internal
;;;
;;; Like Fast-Read-U-Integer, but the size may be determined at run time.
;;;
(defmacro fast-read-variable-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))))
;;; Fast-Read-S-Integer -- Internal
;;;
;;; Read a signed integer.
;;;
(defmacro fast-read-s-integer (n)
(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 ,res 8)))
(cnt 1 (1+ cnt)))
((>= cnt n) res))))
;;; Read-Arg -- Internal
;;;
;;; Read an N-byte unsigned integer from the *fasl-file*
;;;
(defmacro read-arg (n)
(if (= n 1)
`(read-byte *fasl-file*)
`(prepare-for-fast-read-byte *fasl-file*
(prog1
(fast-read-u-integer ,n)
(done-with-fast-read-byte)))))
;;; Fasload:
(defun fasload (stream)
(unless (listen stream)
(error "Attempt to load an empty FASL FILE:~% ~S" stream))
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
(when *load-verbose*
(format t "~&; Loading stuff from ~S.~%" stream))
(let* ((*fasl-file* stream)
(*current-fop-table* (pop *free-fop-tables*))
(*current-fop-table-size* ())
(*current-fop-table-index* 0)
(*fop-stack-pointer-on-entry* *fop-stack-pointer*))
(if (null *current-fop-table*)
(setq *current-fop-table* (make-array 1000)))
(setq *current-fop-table-size*
(length (the simple-vector *current-fop-table*)))
(unwind-protect
(do ((loaded-group (load-group stream) (load-group stream)))
((not loaded-group)))
(setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
;;
;; Nil out the table, so we don't hold onto garbage.
(let ((tab *current-fop-table*))
(dotimes (i *current-fop-table-index*)
(declare (fixnum i))
(setf (svref tab i) nil))
(push tab *free-fop-tables*))
;;
;; Ditto for the stack...
(dotimes (i *fop-stack-pointer-on-entry*)
(declare (fixnum i))
(setf (svref *fop-stack* i) nil))))
t)
#|
(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-codes 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))))))
|#
;;; Load-Group -- Internal
;;;
;;; Load-Group returns t if it successfully loads a group from the file,
;;; or () if EOF was encountered while trying to read from the file.
;;; Dispatch to the right function for each fop. Special-case fop-byte-push
;;; since it is real common.
;;;
(defun load-group (file)
(when (check-header file)
(catch 'group-end
(let ((*current-code-format* nil))
(let ((byte (read-byte file)))
(if (eql byte 3)
(let ((index *fop-stack-pointer*))
(when (zerop index)
(grow-fop-stack)
(setq index *fop-stack-pointer*))
(decf index)
(setq *fop-stack-pointer* index)
(setf (svref *fop-stack* index)
(svref *current-fop-table* (read-byte file))))
(funcall (svref fop-functions byte)))))))))
;;; Check-Header returns t if t succesfully read a header from the file,
;;; or () if EOF was hit before anything was read. An error is signaled
;;; if garbage is encountered.
(defun check-header (file)
(let ((byte (read-byte file NIL '*eof*)))
(cond ((eq byte '*eof*) ())
(do ((byte (read-byte file) (read-byte file))
(count 1 (1+ count)))
((= byte 255) t)
(declare (fixnum byte))
(if (and (< count 9)
(not (eql byte (char-code (schar "FASL FILE" count)))))
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
(error "Bad FASL file format."))))
(t (error "Bad FASL file format.")))))
;;; Load-S-Integer loads a signed integer Length bytes long from the File.
(defun load-s-integer (length)
(declare (fixnum length))
(do* ((index length (1- index))
(byte 0 (read-byte *fasl-file*))
(result 0 (+ result (ash byte bits)))
(bits 0 (+ bits 8)))
((= index 0)
(if (logbitp 7 byte) ; look at sign bit
(- result (ash 1 bits))
result))
(declare (fixnum index byte bits))))
;;; Sloload:
;;; Something not EQ to anything read from a file:
(defconstant load-eof-value '(()))
;;; Sloload loads a text file into the given Load-Package.
(defun sloload (stream)
(when *load-verbose*
(format t "~&; Loading stuff from ~S.~%" stream))
(do ((sexpr (read stream nil load-eof-value)
(read stream nil load-eof-value)))
((eq sexpr load-eof-value))
(if *load-print-stuff*
(format t "~&; ~S~%" (eval sexpr))
(eval sexpr))))))
;;; Load:
(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*)
((:print *load-print-stuff*) *load-print-stuff*)
(if-does-not-exist :error))
"Loads the file named by Filename into the Lisp environment. See manual
for details."
(let ((*package* *package*))
(if (streamp filename)
(if (equal (stream-element-type filename) '(unsigned-byte 8))
(fasload filename)
(sloload filename))
(let* ((pn (merge-pathnames (pathname filename)
*default-pathname-defaults*))
(tn (probe-file pn)))
(cond
(tn
(if (string-equal (pathname-type tn)
#.(c:backend-fasl-file-type c:*backend*))
(with-open-file (file tn
:direction :input
:element-type '(unsigned-byte 8))
(fasload file))
(with-open-file (file tn :direction :input)
(sloload file)))
t)
((pathname-type pn)
(let ((stream (open pn :direction :input
:if-does-not-exist if-does-not-exist)))
(when stream
(sloload stream)
(close stream)
t)))
(t
(let* ((srcn (make-pathname :type "lisp" :defaults pn))
(src (probe-file srcn))
(objn (make-pathname :type
#.(c:backend-fasl-file-type c:*backend*)
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
(obj (probe-file objn)))
(cond
(obj
(cond ((and src (> (file-write-date src)
(file-write-date obj)))
(case *load-if-source-newer*
(:load-object
(warn "Loading object file ~A, which is~% ~
older than the presumed source, ~A."
(namestring obj)
(namestring src))
(load obj))
(:load-source
(warn "Loading source file ~A, which is~% ~
newer than the presumed object file, ~A."
(namestring src)
(namestring obj))
(load src))
(:compile
(compile-file (namestring src))
(load obj))
(:query
(if (y-or-n-p "Load source file ~A which is newer~% ~
than presumed object file ~A? "
(namestring src)
(namestring obj))
(load src)
(load obj)))
(T (error "*Load-if-source-newer* contains ~A which is not one of:~% ~
:load-object, :load-source, :compile, or :query."
*load-if-source-newer*))))
(T (load obj))))
(t
(load srcn :if-does-not-exist if-does-not-exist))))))))))
;;;; Actual FOP definitions:
(define-fop (fop-nop 0 :nope))
(define-fop (fop-pop 1 nil) (push-table (pop-stack)))
(define-fop (fop-pop-for-effect 65 nil) (pop-stack))
(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
(define-fop (fop-empty-list 4) ())
(define-fop (fop-truth 5) t)
(define-fop (fop-misc-trap 66)
(%primitive make-other-immediate-type 0 vm:unbound-marker-type))
(define-fop (fop-short-character 69)
(code-char (read-arg 1)))
(clone-fop (fop-struct 48)
(fop-small-struct 49)
(let* ((size (clone-arg))
(res (make-structure size)))
(declare (type index size))
(do ((n (1- size) (1- n)))
((minusp n))
(declare (type (integer -1 #.most-positive-fixnum) n))
(setf (structure-ref res n) (pop-stack)))
res))
(define-fop (fop-end-group 64 :nope) (throw 'group-end t))
(define-fop (fop-end-header 255)
(error "Fop-End-Header was executed???"))
;;; In the normal loader, we just ignore these. Genesis overwrites
;;; fop-maybe-cold-load with something that knows when to revert to
;;; cold-loading or not.
;;;
(define-fop (fop-maybe-cold-load 82 :nope))
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
(define-fop (fop-verify-table-size 62 :nope)
(if (/= *current-fop-table-index* (read-arg 4))
(error "Fasl table of improper size. Bug!")))
(define-fop (fop-verify-empty-stack 63 :nope)
(if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
(error "Fasl stack not empty. Bug!")))
;;;; Loading symbols:
(defvar *load-symbol-buffer* (make-string 100))
(defvar *load-symbol-buffer-size* 100)
(macrolet ((frob (name code name-size package)
(let ((n-package (gensym))
(n-size (gensym))
(n-buffer (gensym)))
`(define-fop (,name ,code)
(prepare-for-fast-read-byte *fasl-file*
(let ((,n-package ,package)
(,n-size (fast-read-u-integer ,name-size)))
(when (> ,n-size *load-symbol-buffer-size*)
(setq *load-symbol-buffer*
(make-string (setq *load-symbol-buffer-size*
(* ,n-size 2)))))
(done-with-fast-read-byte)
(let ((,n-buffer *load-symbol-buffer*))
(read-n-bytes *fasl-file* ,n-buffer 0 ,n-size)
(push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
(frob fop-symbol-save 6 4 *package*)
(frob fop-small-symbol-save 7 1 *package*)
(frob fop-lisp-symbol-save 75 4 *lisp-package*)
(frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
(frob fop-keyword-symbol-save 77 4 *keyword-package*)
(frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
(frob fop-symbol-in-package-save 8 4
(svref *current-fop-table* (fast-read-u-integer 4)))
(frob fop-small-symbol-in-package-save 9 1
(svref *current-fop-table* (fast-read-u-integer 4)))
(frob fop-symbol-in-byte-package-save 10 4
(svref *current-fop-table* (fast-read-u-integer 1)))
(frob fop-small-symbol-in-byte-package-save 11 1
(svref *current-fop-table* (fast-read-u-integer 1))))
(clone-fop (fop-uninterned-symbol-save 12)
(fop-uninterned-small-symbol-save 13)
(let* ((arg (clone-arg))
(res (make-string arg)))
(read-n-bytes *fasl-file* res 0 arg)
(push-table (make-symbol res))))
(define-fop (fop-package 14)
(let ((name (pop-stack)))
(or (find-package name)
(error "The package ~S does not exist." name))))
;;;; Loading numbers:
(clone-fop (fop-integer 33)
(fop-small-integer 34)
(load-s-integer (clone-arg)))
(define-fop (fop-word-integer 35)
(prepare-for-fast-read-byte *fasl-file*
(prog1
(fast-read-s-integer 4)
(done-with-fast-read-byte))))
(define-fop (fop-byte-integer 36)
(prepare-for-fast-read-byte *fasl-file*
(prog1
(fast-read-s-integer 1)
(done-with-fast-read-byte))))
(define-fop (fop-ratio 70)
(let ((den (pop-stack)))
(%make-ratio (pop-stack) den)))
(%make-complex (pop-stack) im)))
(define-fop (fop-single-float 46)
(make-single-float (load-s-integer 4)))
(define-fop (fop-double-float 47)
(let ((lo (ldb (byte 32 0) (load-s-integer 4))))
(make-double-float (load-s-integer 4) lo)))
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
;;;; Loading lists:
(define-fop (fop-list 15)
(do ((res () (cons (pop-stack) res))
(n (read-arg 1) (1- n)))
((zerop n) res)))
(define-fop (fop-list* 16)
(do ((res (pop-stack) (cons (pop-stack) res))
(n (read-arg 1) (1- n)))
((zerop n) res)))
(macrolet ((frob (name op fun n)
`(define-fop (,name ,op)
(call-with-popped-things ,fun ,n))))
(frob fop-list-1 17 list 1)
(frob fop-list-2 18 list 2)
(frob fop-list-3 19 list 3)
(frob fop-list-4 20 list 4)
(frob fop-list-5 21 list 5)
(frob fop-list-6 22 list 6)
(frob fop-list-7 23 list 7)
(frob fop-list-8 24 list 8)
(frob fop-list*-1 25 list* 2)
(frob fop-list*-2 26 list* 3)
(frob fop-list*-3 27 list* 4)
(frob fop-list*-4 28 list* 5)
(frob fop-list*-5 29 list* 6)
(frob fop-list*-6 30 list* 7)
(frob fop-list*-7 31 list* 8)
(frob fop-list*-8 32 list* 9))
;;;; Loading arrays:
;;;
(clone-fop (fop-string 37)
(fop-small-string 38)
(let* ((arg (clone-arg))
(res (make-string arg)))
(read-n-bytes *fasl-file* res 0 arg)
res))
(clone-fop (fop-vector 39)
(fop-small-vector 40)
(let* ((size (clone-arg))
(res (make-array size)))
(declare (fixnum size))
(do ((n (1- size) (1- n)))
((minusp n))
(setf (svref res n) (pop-stack)))
res))
(clone-fop (fop-uniform-vector 41)
(fop-small-uniform-vector 42)
(make-array (clone-arg) :initial-element (pop-stack)))
(define-fop (fop-array 83)
(let* ((rank (read-arg 4))
(vec (pop-stack))
(length (length vec))
(res (make-array-header vm:simple-array-type rank)))
(declare (simple-array vec)
(type (unsigned-byte 24) rank))
;;; FOP-INT-VECTOR -- Internal
;;;
;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size
;;; must be a directly supported I-vector element size, with no extra bits.
;;; This must be packed according to the local byte-ordering, allowing us to
;;; directly read the bits.
;;;
(define-fop (fop-int-vector 43)
(prepare-for-fast-read-byte *fasl-file*
(let* ((len (fast-read-u-integer 4))
(size (fast-read-byte))
(res (case size
(1 (make-array len :element-type 'bit))
(2 (make-array len :element-type '(unsigned-byte 2)))
(4 (make-array len :element-type '(unsigned-byte 4)))
(8 (make-array len :element-type '(unsigned-byte 8)))
(16 (make-array len :element-type '(unsigned-byte 16)))
(32 (make-array len :element-type '(unsigned-byte 32)))
(t (error "Losing i-vector element size: ~S" size)))))
(declare (type index len))
(done-with-fast-read-byte)
(read-n-bytes *fasl-file* res 0 (ceiling (* size len) vm:byte-bits))
res)))
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
(define-fop (fop-uniform-int-vector 44)
(prepare-for-fast-read-byte *fasl-file*
(let* ((n (fast-read-u-integer 4))
(size (fast-read-byte))
(value (fast-read-variable-u-integer (ceiling size 8))))
(done-with-fast-read-byte)
(make-array n :element-type `(unsigned-byte ,size)
:initial-element value))))
(define-fop (fop-eval 53)
(let ((result (eval (pop-stack))))
(when *load-print-stuff*
(format t "~&; ~S~%" result))
result))
(define-fop (fop-eval-for-effect 54 nil)
(let ((result (eval (pop-stack))))
(when *load-print-stuff*
(format t "~&; ~S~%" result))))
(define-fop (fop-funcall 55)
(let ((arg (read-arg 1)))
(if (zerop arg)
(funcall (pop-stack))
(do ((args () (cons (pop-stack) args))
(n arg (1- n)))
((zerop n) (apply (pop-stack) args))))))
(define-fop (fop-funcall-for-effect 56 nil)
(let ((arg (read-arg 1)))
(if (zerop arg)
(funcall (pop-stack))
(do ((args () (cons (pop-stack) args))
(n arg (1- n)))
((zerop n) (apply (pop-stack) args))))))
;;;; Fixing up circularities.
(define-fop (fop-rplaca 200 nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4))
(val (pop-stack)))
(setf (car (nthcdr idx obj)) val)))
(define-fop (fop-rplacd 201 nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4))
(val (pop-stack)))
(setf (cdr (nthcdr idx obj)) val)))
(define-fop (fop-svset 202 nil)
(let* ((obi (read-arg 4))
(obj (svref *current-fop-table* obi))
(idx (read-arg 4))
(val (pop-stack)))
(if (structurep obj)
(setf (c::structure-ref obj idx) val)
(setf (svref obj idx) val))))
(define-fop (fop-structset 204 nil)
(setf (c::structure-ref (svref *current-fop-table* (read-arg 4))
(read-arg 4))
(pop-stack)))
(define-fop (fop-nthcdr 203 t)
(nthcdr (read-arg 4) (pop-stack)))
;;;; Loading functions:
(define-fop (fop-code-format 57 :nope)
(setf *current-code-format*
(cons (read-arg 1) (read-arg 1))))
;;; Load-Code loads a code object. NItems objects are popped off the stack for
;;; the boxed storage section, then Size bytes of code are read in.
`(if *current-code-format*
(let ((implementation (car *current-code-format*))
(version (cdr *current-code-format*)))
(unless (= implementation
#.(c:backend-fasl-file-implementation c:*backend*))
(error "~A was compiled for a ~A, but this is a ~A"
*Fasl-file*
(or (elt c:fasl-file-implementations implementation)
"unknown machine")
(or (elt c:fasl-file-implementations
#.(c:backend-fasl-file-implementation c:*backend*))
"unknown machine")))
(unless (= version #.(c:backend-fasl-file-version c:*backend*))
(error "~A was compiled for fasl-file version ~A, ~
but this is version ~A"
*Fasl-file* version #.(c:backend-fasl-file-version c:*backend*)))
(let ((box-num ,nitems)
(code-length ,size))
(declare (fixnum box-num code-length))
(let ((code (%primitive allocate-code-object box-num code-length))
(index (+ vm:code-trace-table-offset-slot box-num)))
(setf (code-header-ref code vm:code-debug-info-slot) (pop-stack))
(dotimes (i box-num)
(declare (fixnum i))
(setf (code-header-ref code (decf index)) (pop-stack)))
(system:without-gcing
(read-n-bytes *fasl-file* (code-instructions code) 0
code-length))
code)))
(error
"Code Format not set? Can't load code until after FOP-CODE-FORMAT.")))
(load-code (read-arg 4) (read-arg 4)))
(load-code (read-arg 1) (read-arg 2)))
;;; Now a NOOP except in cold load...
(define-fop (fop-fset 74 nil)
(pop-stack)
(pop-stack))
;;; Modify a slot in a Constants object.
;;;
(clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141)
(let ((value (pop-stack))
(code (pop-stack)))
(setf (code-header-ref code (clone-arg)) value)
(let ((type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(offset (read-arg 4)))
(declare (type index offset))
(unless (zerop (logand offset vm:lowtag-mask))
(error "Unaligned function object, offset = #x~X." offset))
(let ((fun (%primitive compute-function code-object offset)))
(%primitive set-function-self fun fun)
(%primitive set-function-next fun
(%primitive code-entry-points code-object))
(%primitive set-code-entry-points code-object fun)
(%primitive set-function-name fun name)
(%primitive set-function-arglist fun arglist)
(%primitive set-function-type fun type)
(when *load-print-stuff*
(format t "~&; ~S defined" fun))
;;; These two variables are initially filled in by Genesis.
(defvar *initial-assembler-routines*)
(defvar *initial-foreign-symbols*)
(defvar *assembler-routines* (make-hash-table :test #'eq))
(defvar *foreign-symbols* (make-hash-table :test #'equal))
(defun loader-init ()
(dolist (routine *initial-assembler-routines*)
(setf (gethash (car routine) *assembler-routines*) (cdr routine)))
(dolist (symbol *initial-foreign-symbols*)
(setf (gethash (car symbol) *foreign-symbols*) (cdr symbol)))
(makunbound '*initial-assembler-routines*)
(makunbound '*initial-foreign-symbols*))
(define-fop (fop-foreign-fixup 147)
(let* ((kind (pop-stack))
(code-object (pop-stack))
(len (read-arg 1))
(sym (make-string len)))
(read-n-bytes *fasl-file* sym 0 len)
(multiple-value-bind
(value found)
(gethash sym *foreign-symbols* 0)
(unless found
(error "Unknown foreign symbol: ~S" sym))
(vm:fixup-code-object code-object (read-arg 4) value kind))
code-object))
(define-fop (fop-assembler-code 144)
(error "Cannot load assembler code."))
(define-fop (fop-assembler-routine 145)
(error "Cannot load assembler code."))
(define-fop (fop-assembler-fixup 148)
(let ((routine (pop-stack))
(kind (pop-stack))
(code-object (pop-stack)))
(multiple-value-bind
(value found)
(gethash routine *assembler-routines*)
(unless found
(error "Undefined assembler routine: ~S" routine))
(vm:fixup-code-object code-object (read-arg 4) value kind))
code-object))