Newer
Older
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
;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice 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 Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Loader for Spice Lisp.
;;; Written by Skef Wholey and Rob MacLachlan.
;;;
(in-package "LISP")
(export '(load *load-verbose*))
(in-package "SYSTEM")
(export 'resolve-loaded-assembler-references)
(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.")
(defvar *in-cold-load* nil) ; True if we are in the cold loader.
(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.")
(proclaim '(special cold-fop-functions))
;;;; 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)
(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* 'uninitialized-code-format))
(loop
(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*) ())
((eq byte (char-int #\F))
(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-int (schar "FASL FILE" count)))))
(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 (or (string-equal (pathname-type tn) "nfasl")
(string-equal (pathname-type tn) "fasl"))
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
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
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
578
579
580
581
582
583
584
585
586
587
588
589
590
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
655
656
657
658
659
(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 "nfasl" :defaults pn))
(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-immediate-type 0 lisp::%trap-type))
(define-fop (fop-character 68)
(int-char (read-arg 3)))
(define-fop (fop-short-character 69)
(code-char (read-arg 1)))
(define-fop (fop-structure 79)
(%primitive set-vector-subtype (pop-stack) 1))
(define-fop (fop-end-group 64 :nope) (throw 'group-end t))
(define-fop (fop-end-header 255)
(error "Fop-End-Header was executed???"))
(define-fop (fop-normal-load 81 :nope))
(define-fop (fop-maybe-cold-load 82 :nope)
(when *in-cold-load*
(setq fop-functions cold-fop-functions)))
(define-fop (fop-static-heap 60 :nope))
(define-fop (fop-dynamic-heap 61 :nope))
(define-fop (fop-read-only-heap 67 :nope))
(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)))
(%primitive make-ratio (pop-stack) den)))
(define-fop (fop-complex 71)
(let ((im (pop-stack)))
(%primitive make-complex (pop-stack) im)))
(define-fop (fop-float 45)
(let* ((n (read-arg 1))
(exponent (load-s-integer (ceiling n 8)))
(m (read-arg 1))
(mantissa (load-s-integer (ceiling m 8)))
(number (cond ((or (> n 9) (> m 32))
(coerce mantissa 'long-float))
((> m 21)
(coerce mantissa 'single-float))
(T (coerce mantissa 'short-float)))))
(multiple-value-bind (f ex s) (decode-float number)
(declare (ignore ex))
(* s (scale-float f exponent)))))
;;;; 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))
(size (+ rank %array-first-dim-slot))
(length (length vec))
(res (%primitive alloc-array rank)))
(declare (simple-array vec))
(set-array-header res vec length length 0
(do ((i (1- size) (1- i))
(dimensions () (cons (pop-stack) dimensions)))
((< i %array-first-dim-slot) dimensions))
nil)
res))
;;; 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))
(ac (1- (integer-length size)))
(res (%primitive alloc-i-vector len ac)))
(done-with-fast-read-byte)
(unless (and (<= ac 5) (= size (ash 1 ac)))
(error "Losing element size ~S." size))
(read-n-bytes *fasl-file* res 0 (ash (+ (ash len ac) 7) -3))
res)))
679
680
681
682
683
684
685
686
687
688
689
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
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(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-alter 52 nil)
(let ((index (read-arg 1))
(newval (pop-stack))
(object (pop-stack)))
(declare (fixnum index))
(typecase object
(list (case index
(0 (rplaca object newval))
(1 (rplacd object newval))
(t (error "~S: Bad index for FaslOP Alter. Bug!"))))
(symbol (case index
(0 (set object newval))
(1 (setf (symbol-function object) newval))
(2 (setf (symbol-plist object) newval))
(t (error "~S: Bad index for FaslOP Alter. Bug!"))))
(array (setf (aref object index) newval))
(t (error "~S: Bad object for FaslOP Alter. Bug!")))))
(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)))
(setf (svref obj idx) val)))
(define-fop (fop-nthcdr 203 t)
(nthcdr (read-arg 4) (pop-stack)))
;;;; Loading functions:
(define-fop (fop-code-format 57 :nope)
(setq *current-code-format* (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. This must
;;; be done WITHOUT-GCING, since GC only recognizes code object references that
;;; appear in a function object. If a GC happened before we stored the code
;;; object, the code would disappear.
;;;
(defmacro load-code (nitems size)
`(without-gcing
(let ((box-num ,nitems)
(code-length ,size))
(declare (fixnum box-num code-length))
(let ((function (%primitive alloc-function box-num)))
(%primitive set-vector-subtype function %function-constants-subtype)
(do ((index (1- box-num) (1- index)))
((minusp index))
(declare (fixnum index))
(%primitive header-set function index (pop-stack)))
(let ((code (%primitive alloc-code code-length)))
(read-n-bytes *fasl-file* code 0 code-length)
(%primitive header-set function %function-code-slot code))
(when *load-print-stuff*
(format t "~&; ~S~%" function))
function))))
(define-fop (fop-code 58)
(if (eql *current-code-format* %fasl-code-format)
(load-code (read-arg 4) (read-arg 4))
(error "~A has an incompatible fasl file format.~@
You must recompile the source code."
*fasl-file*)))
(define-fop (fop-small-code 59)
(if (eql *current-code-format* %fasl-code-format)
(load-code (read-arg 1) (read-arg 2))
(error "~A has an incompatible fasl file format.~@
You must recompile the source code."
*fasl-file*)))
;;; 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))
(index (clone-arg)))
(%primitive header-set code index value)))
;;; Kind of like Load-Code, except that we set the Code and Constants
;;; slots from the Constants object that is our first stack argument. The
;;; subtype is set to the second stack argument.
;;;
(define-fop (fop-function-entry 142)
(let* ((box-num (read-arg 1))
(function (%primitive alloc-function box-num)))
;;
;; Pop boxed things, storing them in the allocated entry object.
(do ((index (1- box-num) (1- index)))
((minusp index))
(%primitive header-set function index (pop-stack)))
;;
;; Set the subtype of the entry object.
(%primitive set-vector-subtype function (pop-stack))
;;
;; Set code and constants slots in the entry.
(let* ((constants (pop-stack))
(code (%primitive header-ref constants %function-code-slot)))
(%primitive header-set function %function-code-slot code)
(%primitive header-set function %function-entry-constants-slot
constants))
function))
(define-fop (fop-user-miscop-fixup 134)
(let* ((miscop-name (pop-stack))
(function-object (pop-stack))
(code (%primitive header-ref function-object %function-code-slot))
(offset (read-arg 4))
(loaded-addr (get miscop-name '%loaded-address)))
(unless loaded-addr
(error "Miscop ~A is undefined." miscop-name))
(let ((hi-addr (logior (ash clc::type-assembler-code
clc::type-shift-16)
(logand (ash loaded-addr -16) #xFFFF))))
(setf (aref code (+ offset 1)) (logand hi-addr #xFF))
(setf (aref code (+ offset 2))
(logand (ash loaded-addr -8) #xFF))
(setf (aref code (+ offset 3))
(logand loaded-addr #xFF)))
function-object))
;;;; Loading assembler routines:
;;;
;;; Allocate-Assembler-Code -- Internal
;;;
;;; Allocate some stuff out of assembler code space.
;;;
(defun allocate-assembler-code (bytes)
(let* ((idx (ash %assembler-code-type %alloc-ref-type-shift))
(free (alloc-ref idx))
(new (+ free bytes)))
(prog1
(%primitive make-immediate-type free %assembler-code-type)
(%primitive 16bit-system-set alloctable-address idx (ash new -16))
(%primitive 16bit-system-set alloctable-address (1+ idx)
(logand new #xFFFF)))))
(define-fop (fop-assembler-routine 130)
(let* ((code-length (read-arg 4))
(buffer (make-array code-length :element-type '(unsigned-byte 8)))
(code (allocate-assembler-code code-length)))
(declare (fixnum code-length))
(read-n-bytes *fasl-file* buffer 0 code-length)
(%primitive byte-blt buffer 0 code 0 code-length)
code))
;;; A list of the miscop definitions which have been loaded but not
;;; resolved. Each element is a cons (name . code-ptr).
;;;
(defvar *miscop-definitions* ())
;;; Recall that the format of a reference is (How Label Location),
;;; where How is one of JI, BI, BA, or L, Label is the label's name, and
;;; Location is the location of the reference. These things are stored on
;;; the list *external-references* as (Name . References), where Name is
;;; the name of the referencing routine, and References is a list of references
;;; in the above format.
;;;
(defvar *external-references* ())
(defvar *user-defined-miscops* ())
(define-fop (fop-fixup-miscop-routine 131 nil)
(let* ((external-references (pop-stack))
(external-labels (pop-stack))
(name (pop-stack))
(code (pop-stack))
(start (%primitive make-immediate-type code %+-fixnum-type)))
(dolist (lab external-labels)
(setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
(push (cons name external-references) *external-references*)
(push (cons name code) *miscop-definitions*)))
(define-fop (fop-fixup-user-miscop-routine 133 nil)
(let* ((external-references (pop-stack))
(external-labels (pop-stack))
(name (pop-stack))
(code (pop-stack))
(start (%primitive make-immediate-type code %+-fixnum-type)))
(dolist (lab external-labels)
(setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
(push (cons name external-references) *external-references*)
(pushnew name *user-defined-miscops*)
(setf (get name 'user-miscop) t)))
(define-fop (fop-fixup-assembler-routine 132 nil)
(let* ((external-references (pop-stack))
(external-labels (pop-stack))
(name (pop-stack))
(code (pop-stack))
(start (%primitive make-immediate-type code %+-fixnum-type)))
(dolist (lab external-labels)
(setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
(push (cons name external-references) *external-references*)))
;;; Resolving all the assembler routines' references.
;;; Patch-Instruction -- Internal
;;;
;;; Used to patch an assembler code object. Hi-var and lo-var are
;;; bound to the values of the high and low halfwords in the instruction.
;;; The values may by changed by setting the variables.
;;;
(defmacro patch-instruction ((hi-var lo-var code offset) &body body)
`(let ((,hi-var (%primitive 16bit-system-ref ,code ,offset))
(,lo-var (%primitive 16bit-system-ref ,code (1+ ,offset))))
(multiple-value-prog1
(progn ,@body)
(%primitive 16bit-system-set ,code ,offset ,hi-var)
(%primitive 16bit-system-set ,code (1+ ,offset) ,lo-var))))
;;; Resolve-Loaded-Assembler-References -- Public
;;;
;;; Fix up the recorded external references and define the miscops.
;;;
(defun resolve-loaded-assembler-references ()
"This function resolves external label references in loaded assembler
routines. It should be called after assembler files have been loaded.
Miscop definitions do not take effect until this function is called."
(dolist (reflist *external-references*)
(let* ((code-byte-offset (get (car reflist) '%loaded-address))
(code-halfword-offset (ash code-byte-offset -1))
(address (%primitive make-immediate-type code-byte-offset
%assembler-code-type)))
(dolist (refs (cdr reflist))
(let ((how (car refs))
(label (get (cadr refs) '%loaded-address))
(location (caddr refs)))
(unless label
(error "~A references ~A, which has not been defined.~%"
(car reflist) (cadr refs)))
(let ((offset (- (- (ash label -1) code-halfword-offset) location)))
(ecase how
(clc::ji
(unless (<= #x-80 offset #x7F)
(error "Offset #X~X out of JI range for ~A to reference ~A.~%"
offset (car reflist) (cadr refs)))
(patch-instruction (hi lo address location)
(setf (ldb (byte 8 0) hi) offset)))
(clc::bi
(unless (<= #x-80000 offset #x7FFFF)
(error "Offset #X~X out of BI range for ~A to reference ~A.~%"
offset (car reflist) (cadr refs)))
(patch-instruction (hi lo address location)
(setf (ldb (byte 4 0) hi) (ash offset -16))
(setq lo (logand offset #xFFFF))))
(clc::ba (error "I can't resolve a BA reference yet.~%"))
(clc::l (error "I can't resolve an L reference yet.~%"))))))))
(setq *external-references* ())
(dolist (mo *miscop-definitions*)
(let* ((name (intern (symbol-name (car mo)) (find-package "COMPILER")))
(index (get name 'clc::transfer-vector-index)))
(if index