Fix FORMAT compilation on non-simple strings.
[sbcl.git] / src / code / fop.lisp
blob8a0ce6dc81c7f396cb79c595627fde0ab6a3d2ef
1 ;;;; FOP definitions
3 (in-package "SB!FASL")
5 ;;; Bind STACK-VAR and PTR-VAR to the start of a subsequence of
6 ;;; the fop stack of length COUNT, then execute BODY.
7 ;;; Within the body, FOP-STACK-REF is used in lieu of SVREF
8 ;;; to elide bounds checking.
9 (defmacro with-fop-stack (((stack-var &optional stack-expr) ptr-var count)
10 &body body)
11 `(macrolet ((fop-stack-ref (i)
12 `(locally
13 #-sb-xc-host
14 (declare (optimize (sb!c::insert-array-bounds-checks 0)))
15 (svref ,',stack-var (truly-the index ,i)))))
16 (let* (,@(when stack-expr
17 (list `(,stack-var (the simple-vector ,stack-expr))))
18 (,ptr-var (truly-the index (fop-stack-pop-n ,stack-var ,count))))
19 ,@body)))
21 ;;; Define NAME as a fasl operation, with op-code FOP-CODE.
22 ;;; PUSHP describes what the body does to the fop stack:
23 ;;; T - The result of the body is pushed on the fop stack.
24 ;;; NIL - The result of the body is discarded.
25 ;;; In either case, the body is permitted to pop the stack.
26 ;;;
27 (defmacro !define-fop (fop-code &rest stuff)
28 (multiple-value-bind (name allowp operands stack-args pushp forms)
29 (let ((allowp (if (eq (car stuff) :not-host)
30 (progn (pop stuff) (or #+sb-xc t))
31 t)))
32 (destructuring-bind ((name &optional arglist (pushp t)) . forms) stuff
33 (aver (member pushp '(nil t)))
34 (multiple-value-bind (operands stack-args)
35 (if (atom (car arglist))
36 (values nil arglist)
37 (ecase (caar arglist)
38 (:operands (values (cdar arglist) (cdr arglist)))))
39 (assert (<= (length operands) 3))
40 (values name allowp operands stack-args pushp forms))))
41 `(progn
42 (defun ,name (.fasl-input. ,@operands)
43 (declare (ignorable .fasl-input.))
44 ,@(if allowp
45 `((macrolet
46 ((fasl-input () '(truly-the fasl-input .fasl-input.))
47 (fasl-input-stream () '(%fasl-input-stream (fasl-input)))
48 (operand-stack () '(%fasl-input-stack (fasl-input)))
49 (skip-until () '(%fasl-input-skip-until (fasl-input))))
50 ,@(if (null stack-args)
51 forms
52 (with-unique-names (stack ptr)
53 `((with-fop-stack ((,stack (operand-stack))
54 ,ptr ,(length stack-args))
55 (multiple-value-bind ,stack-args
56 (values ,@(loop for i below (length stack-args)
57 collect `(fop-stack-ref (+ ,ptr ,i))))
58 ,@forms)))))))
59 `((declare (ignore ,@operands))
60 (error ,(format nil "Not-host fop invoked: ~A" name)))))
61 (!%define-fop ',name ,fop-code ,(length operands) ,(if pushp 1 0)))))
63 (defun !%define-fop (name base-opcode n-operands pushp)
64 (declare (type (mod 4) n-operands))
65 ;; If at least one non-stack operand is present, the same fop function
66 ;; appears in 4 consecutive cells in the fop table, with the low 2 bits
67 ;; of the fopcode determining the number of additional bytes to read
68 ;; for the first operand. The second and third operands are varint-encoded.
69 (let ((n-slots (if (plusp n-operands) 4 1)))
70 (unless (zerop (mod base-opcode n-slots))
71 (error "Opcode for fop ~S must be a multiple of ~D" name n-slots))
72 (loop for opcode from base-opcode below (+ base-opcode n-slots)
73 for function = (svref **fop-funs** opcode)
74 when (functionp function)
75 do (let ((oname (nth-value 2 (function-lambda-expression function))))
76 (when (and oname (not (eq oname name)))
77 (error "fop ~S with opcode ~D conflicts with fop ~S."
78 name opcode oname))))
79 (let ((existing-opcode (get name 'opcode)))
80 (when (and existing-opcode (/= existing-opcode base-opcode))
81 (error "multiple codes for fop name ~S: ~D and ~D"
82 name base-opcode existing-opcode)))
83 (setf (get name 'opcode) base-opcode)
84 ;; The low 2 bits of the opcode comprise the length modifier if there is
85 ;; at least one non-stack integer operand.
86 ;; If there is more than 1, they follow, using varint encoding.
87 (dotimes (j n-slots)
88 (let ((opcode (+ base-opcode j)))
89 (setf (svref **fop-funs** opcode) (symbol-function name)
90 (aref (car **fop-signatures**) opcode) n-operands
91 (sbit (cdr **fop-signatures**) opcode) pushp))))
92 name)
94 ;;; a helper function for reading string values from FASL files: sort
95 ;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
96 ;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
97 ;;; for each element read
98 (defun read-string-as-bytes (stream string &optional (length (length string)))
99 (declare (type (simple-array character (*)) string)
100 (type index length)
101 (optimize speed))
102 (with-fast-read-byte ((unsigned-byte 8) stream)
103 (dotimes (i length)
104 (setf (aref string i)
105 (sb!xc:code-char (fast-read-byte)))))
106 string)
107 (defun read-base-string-as-bytes (stream string &optional (length (length string)))
108 (declare (type (simple-array base-char (*)) string)
109 (type index length)
110 (optimize speed))
111 (with-fast-read-byte ((unsigned-byte 8) stream)
112 (dotimes (i length)
113 (setf (aref string i)
114 (sb!xc:code-char (fast-read-byte)))))
115 string)
116 #!+(and sb-unicode (host-feature sb-xc))
117 (defun read-string-as-unsigned-byte-32
118 (stream string &optional (length (length string)))
119 (declare (type (simple-array character (*)) string)
120 (type index length)
121 (optimize speed))
122 (with-fast-read-byte ((unsigned-byte 8) stream)
123 (dotimes (i length)
124 (setf (aref string i)
125 (sb!xc:code-char (fast-read-u-integer 4)))))
126 string)
128 ;;;; miscellaneous fops
130 ;;; Setting this variable causes execution of a FOP-NOP4 to produce
131 ;;; output to *DEBUG-IO*. This can be handy when trying to follow the
132 ;;; progress of FASL loading.
133 #!+sb-show
134 (defvar *show-fop-nop4-p* nil)
136 ;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0
137 ;;; occurs disproportionately often in fasl files for other reasons,
138 ;;; FOP-NOP is less than ideal for writing human-readable patterns
139 ;;; into fasl files for debugging purposes. There's no shortage of
140 ;;; unused fop codes, so we add this second NOP, which reads 4
141 ;;; arbitrary bytes and discards them.
142 (!define-fop 137 (fop-nop4 () nil)
143 (let ((arg (read-arg 4 (fasl-input-stream))))
144 (declare (ignorable arg))
145 #!+sb-show
146 (when *show-fop-nop4-p*
147 (format *debug-io* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg))))
149 (!define-fop 0 (fop-nop () nil))
150 (!define-fop 1 (fop-pop (x) nil) (push-fop-table x (fasl-input)))
151 (!define-fop 2 (fop-empty-list) nil)
152 (!define-fop 3 (fop-truth) t)
153 (!define-fop 4 (fop-push ((:operands index)))
154 (ref-fop-table (fasl-input) index))
155 (!define-fop 9 (fop-move-to-table (x))
156 (push-fop-table x (fasl-input))
159 (!define-fop 66 :not-host (fop-misc-trap)
160 (make-unbound-marker))
162 (!define-fop 76 (fop-character ((:operands char-code)))
163 (code-char char-code))
165 ;; %MAKE-INSTANCE does not exist on the host.
166 (!define-fop 48 :not-host (fop-struct ((:operands size) layout))
167 (let ((res (%make-instance size)) ; number of words excluding header
168 ;; Discount the layout from number of user-visible words.
169 (n-data-words (- size sb!vm:instance-data-start)))
170 (setf (%instance-layout res) layout)
171 (with-fop-stack ((stack (operand-stack)) ptr n-data-words)
172 (declare (type index ptr))
173 (let ((bitmap (layout-bitmap layout)))
174 ;; Values on the stack are in the same order as in the structure itself.
175 (do ((i sb!vm:instance-data-start (1+ i)))
176 ((>= i size))
177 (declare (type index i))
178 (let ((val (fop-stack-ref ptr)))
179 (if (logbitp i bitmap)
180 (setf (%instance-ref res i) val)
181 (setf (%raw-instance-ref/word res i) val))
182 (incf ptr)))))
183 res))
185 (!define-fop 45 :not-host (fop-layout (name inherits depthoid length bitmap))
186 (let ((flags
187 (case (and (>= (length (the simple-vector inherits)) 2)
188 (elt inherits 1))
189 (#.(find-layout 'structure-object) +structure-layout-flag+)
190 (#.(find-layout 'condition) +condition-layout-flag+)
191 ;; DUMP-LAYOUT avers that +pcl-object-flag+ layouts are never dumped
192 (t 0))))
193 (find-and-init-or-check-layout name length flags inherits depthoid bitmap)))
195 ;; Allocate a CLOS object. This is used when the compiler detects that
196 ;; MAKE-LOAD-FORM returned a simple use of MAKE-LOAD-FORM-SAVING-SLOTS,
197 ;; or possibly a hand-written equivalent (however unlikely).
198 (!define-fop 68 :not-host (fop-allocate-instance (name) nil)
199 (let ((instance (allocate-instance (find-class (the symbol name)))))
200 (push-fop-table instance (fasl-input))))
202 ;; Fill in object slots as dictated by the second return value from
203 ;; MAKE-LOAD-FORM-SAVING-SLOTS.
204 ;; This wants a 'count' as the first item in the SLOT-NAMES argument
205 ;; rather than using read-arg because many calls of this might share
206 ;; the list, which must be constructed into the fop-table no matter what.
207 (!define-fop 69 :not-host (fop-set-slot-values (slot-names obj) nil)
208 (let* ((n-slots (pop slot-names))
209 (stack (operand-stack))
210 (ptr (fop-stack-pop-n stack n-slots)))
211 (dotimes (i n-slots)
212 (let ((val (svref stack (+ ptr i)))
213 (slot-name (pop slot-names)))
214 (if (unbound-marker-p val)
215 ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
216 (slot-makunbound obj slot-name)
217 (setf (slot-value obj slot-name) val))))))
219 (!define-fop 64 (fop-end-group () nil)
220 (/show0 "THROWing FASL-GROUP-END")
221 (throw 'fasl-group-end t))
223 ;;; We used to have FOP-NORMAL-LOAD as 81 and FOP-MAYBE-COLD-LOAD as
224 ;;; 82 until GENESIS learned how to work with host symbols and
225 ;;; packages directly instead of piggybacking on the host code.
227 (!define-fop 62 (fop-verify-table-size () nil)
228 (let ((expected-index (read-word-arg (fasl-input-stream))))
229 (unless (= (svref (%fasl-input-table (fasl-input)) 0) expected-index)
230 (bug "fasl table of improper size"))))
231 (!define-fop 63 (fop-verify-empty-stack () nil)
232 (unless (fop-stack-empty-p (operand-stack))
233 (bug "fasl stack not empty when it should be")))
235 ;;;; fops for loading symbols
237 (defstruct (undefined-package (:copier nil))
238 (error nil :read-only t))
239 (declaim (freeze-type undefined-package))
241 ;; Cold load has its own implementation of all symbol fops,
242 ;; but we have to execute define-fop now to assign their numbers.
243 (labels #+sb-xc-host ()
244 #-sb-xc-host
245 ((read-symbol-name (length+flag fasl-input)
246 (let* ((namelen (ash (the fixnum length+flag) -1))
247 (base-p (logand length+flag 1))
248 (elt-type (if (eql base-p 1) 'base-char 'character))
249 (buffer (%fasl-input-name-buffer fasl-input))
250 (string (the string (svref buffer base-p))))
251 (when (< (length string) namelen) ; grow
252 (setf string (make-string namelen :element-type elt-type)
253 (svref buffer base-p) string))
254 (funcall (if (eql base-p 1)
255 'read-base-string-as-bytes
256 'read-string-as-unsigned-byte-32)
257 (%fasl-input-stream fasl-input) string namelen)
258 (values string namelen elt-type)))
259 (aux-fop-intern (length+flag package fasl-input)
260 (multiple-value-bind (name length elt-type)
261 (read-symbol-name length+flag fasl-input)
262 (if (undefined-package-p package)
263 (error 'simple-package-error
264 :format-control "Error finding package for symbol ~s:~% ~a"
265 :format-arguments
266 (list (subseq name 0 length)
267 (undefined-package-error package)))
268 (push-fop-table (without-package-locks
269 (%intern name length package elt-type))
270 fasl-input))))
271 ;; Symbol-hash is usually computed lazily and memoized into a symbol.
272 ;; Laziness slightly improves the speed of allocation.
273 ;; But when loading fasls, the time spent in the loader totally swamps
274 ;; any time savings of not precomputing symbol-hash.
275 ;; INTERN hashes everything anyway, so let's be consistent
276 ;; and precompute the hashes of uninterned symbols too.
277 (ensure-hashed (symbol)
278 (ensure-symbol-hash symbol)
279 symbol))
281 #-sb-xc-host (declare (inline ensure-hashed))
282 (!define-fop 80 :not-host (fop-lisp-symbol-save ((:operands length+flag)))
283 (aux-fop-intern length+flag *cl-package* (fasl-input)))
284 (!define-fop 84 :not-host (fop-keyword-symbol-save ((:operands length+flag)))
285 (aux-fop-intern length+flag *keyword-package* (fasl-input)))
286 (!define-fop #xF0 :not-host (fop-symbol-in-package-save ((:operands length+flag pkg-index)))
287 (aux-fop-intern length+flag (ref-fop-table (fasl-input) pkg-index) (fasl-input)))
289 (!define-fop 96 :not-host (fop-uninterned-symbol-save ((:operands length+flag)))
290 (multiple-value-bind (name len) (read-symbol-name length+flag (fasl-input))
291 (push-fop-table (ensure-hashed (make-symbol (subseq name 0 len)))
292 (fasl-input))))
294 (!define-fop 104 :not-host (fop-copy-symbol-save ((:operands table-index)))
295 (push-fop-table (ensure-hashed
296 (copy-symbol (ref-fop-table (fasl-input) table-index)))
297 (fasl-input))))
299 (!define-fop 44 (fop-package (pkg-designator))
300 (find-undeleted-package-or-lose pkg-designator))
302 (!define-fop 156 :not-host (fop-named-package-save ((:operands length)) nil)
303 (let ((package-name (make-string length)))
304 #!-sb-unicode (read-string-as-bytes (fasl-input-stream) package-name)
305 #!+sb-unicode (read-string-as-unsigned-byte-32 (fasl-input-stream) package-name)
306 (push-fop-table
307 (handler-case (find-undeleted-package-or-lose package-name)
308 (simple-package-error (c)
309 (make-undefined-package :error (princ-to-string c))))
310 (fasl-input))))
312 ;;;; fops for loading numbers
314 ;;; Load a signed integer LENGTH bytes long from FASL-INPUT-STREAM.
315 (defun load-s-integer (length fasl-input-stream)
316 (declare (fixnum length)
317 (optimize speed))
318 (with-fast-read-byte ((unsigned-byte 8) fasl-input-stream)
319 (do* ((index length (1- index))
320 (byte 0 (fast-read-byte))
321 (result 0 (+ result (ash byte bits)))
322 (bits 0 (+ bits 8)))
323 ((= index 0)
324 (if (logbitp 7 byte) ; look at sign bit
325 (- result (ash 1 bits))
326 result))
327 (declare (fixnum index byte bits)))))
329 (!define-fop 36 (fop-integer ((:operands n-bytes)))
330 (load-s-integer n-bytes (fasl-input-stream)))
332 (!define-fop 34 (fop-word-integer)
333 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
334 (fast-read-s-integer #.sb!vm:n-word-bytes)))
336 (!define-fop 35 (fop-byte-integer)
337 ;; FIXME: WITH-FAST-READ-BYTE for exactly 1 byte is not really faster/better
338 ;; than regular READ-BYTE. The expansion of READ-ARG corroborates this claim.
339 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
340 (fast-read-s-integer 1)))
342 ;; No %MAKE-RATIO on host
343 (!define-fop 70 :not-host (fop-ratio (num den)) (%make-ratio num den))
345 ;; No %MAKE-COMPLEX on host
346 (!define-fop 71 :not-host (fop-complex (realpart imagpart))
347 (%make-complex realpart imagpart))
349 (macrolet ((fast-read-single-float ()
350 '(make-single-float (fast-read-s-integer 4)))
351 (fast-read-double-float ()
352 '(let ((lo (fast-read-u-integer 4)))
353 (make-double-float (fast-read-s-integer 4) lo))))
354 (macrolet ((define-complex-fop (opcode name type)
355 (let ((reader (symbolicate "FAST-READ-" type)))
356 `(!define-fop ,opcode (,name)
357 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
358 (complex (,reader) (,reader))))))
359 (define-float-fop (opcode name type)
360 (let ((reader (symbolicate "FAST-READ-" type)))
361 `(!define-fop ,opcode (,name)
362 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
363 (,reader))))))
364 (define-complex-fop 72 fop-complex-single-float single-float)
365 (define-complex-fop 73 fop-complex-double-float double-float)
366 #!+long-float
367 (define-complex-fop 67 fop-complex-long-float long-float)
368 (define-float-fop 46 fop-single-float single-float)
369 (define-float-fop 47 fop-double-float double-float)
370 #!+long-float
371 (define-float-fop 52 fop-long-float long-float)))
373 #!+sb-simd-pack
374 (!define-fop 88 :not-host (fop-simd-pack)
375 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
376 (%make-simd-pack (fast-read-s-integer 8)
377 (fast-read-u-integer 8)
378 (fast-read-u-integer 8))))
380 ;;;; loading lists
382 (defun fop-list-from-stack (stack n)
383 ;; N is 0-255 when called from FOP-LIST,
384 ;; but it is as large as ARRAY-RANK-LIMIT in FOP-ARRAY.
385 (declare (type (unsigned-byte 16) n)
386 (optimize (speed 3)))
387 (with-fop-stack ((stack) ptr n)
388 (do* ((i (+ ptr n) (1- i))
389 (res () (cons (fop-stack-ref i) res)))
390 ((= i ptr) res)
391 (declare (type index i)))))
393 (!define-fop 33 (fop-list)
394 (fop-list-from-stack (operand-stack) (read-byte-arg (fasl-input-stream))))
395 (!define-fop 16 (fop-list*)
396 ;; N is the number of cons cells (0 is ok)
397 (let ((n (read-byte-arg (fasl-input-stream))))
398 (with-fop-stack ((stack (operand-stack)) ptr (1+ n))
399 (do* ((i (+ ptr n) (1- i))
400 (res (fop-stack-ref (+ ptr n))
401 (cons (fop-stack-ref i) res)))
402 ((= i ptr) res)
403 (declare (type index i))))))
405 (macrolet ((frob (name op fun n)
406 (let ((args (make-gensym-list n)))
407 `(!define-fop ,op (,name ,args) (,fun ,@args)))))
409 (frob fop-list-1 17 list 1)
410 (frob fop-list-2 18 list 2)
411 (frob fop-list-3 19 list 3)
412 (frob fop-list-4 20 list 4)
413 (frob fop-list-5 21 list 5)
414 (frob fop-list-6 22 list 6)
415 (frob fop-list-7 23 list 7)
416 (frob fop-list-8 24 list 8)
418 (frob fop-list*-1 25 list* 2)
419 (frob fop-list*-2 26 list* 3)
420 (frob fop-list*-3 27 list* 4)
421 (frob fop-list*-4 28 list* 5)
422 (frob fop-list*-5 29 list* 6)
423 (frob fop-list*-6 30 list* 7)
424 (frob fop-list*-7 31 list* 8)
425 (frob fop-list*-8 32 list* 9))
427 ;;;; fops for loading arrays
429 (!define-fop 100 :not-host (fop-base-string ((:operands length)))
430 (logically-readonlyize
431 (read-base-string-as-bytes (fasl-input-stream)
432 (make-string length :element-type 'base-char))))
434 ;; FIXME: can save space by UTF-8 encoding, or use 1 bit to indicate pure ASCII
435 ;; in the fasl even though the result will be a non-base string.
436 #!+sb-unicode
437 (!define-fop 160 :not-host (fop-character-string ((:operands length)))
438 (logically-readonlyize
439 (read-string-as-unsigned-byte-32 (fasl-input-stream)
440 (make-string length))))
442 (!define-fop 92 (fop-vector ((:operands size)))
443 (if (zerop size)
445 (let ((res (make-array size))
446 (stack (operand-stack)))
447 (declare (fixnum size))
448 (let ((ptr (fop-stack-pop-n stack size)))
449 (replace res stack :start2 ptr))
450 (logically-readonlyize res))))
452 ;; No MAKE-ARRAY-HEADER on host
453 (!define-fop 89 :not-host (fop-array (vec))
454 (let* ((rank (read-word-arg (fasl-input-stream)))
455 (length (length vec))
456 (res (make-array-header sb!vm:simple-array-widetag rank)))
457 (declare (simple-array vec)
458 (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank))
459 (set-array-header res vec length nil 0
460 (fop-list-from-stack (operand-stack) rank)
461 nil t)
462 res))
464 (defglobal **saetp-bits-per-length**
465 (let ((array (make-array (1+ sb!vm:widetag-mask)
466 :element-type '(unsigned-byte 8)
467 :initial-element 255)))
468 (loop for saetp across sb!vm:*specialized-array-element-type-properties*
470 (setf (aref array (sb!vm:saetp-typecode saetp))
471 (sb!vm:saetp-n-bits saetp)))
472 array)
473 "255 means bad entry.")
474 (declaim (type (simple-array (unsigned-byte 8) (#.(1+ sb!vm:widetag-mask)))
475 **saetp-bits-per-length**))
477 ;; No ALLOCATE-VECTOR on host (nor READ-N-BYTES)
478 (!define-fop 43 :not-host (fop-spec-vector)
479 (let* ((length (read-word-arg (fasl-input-stream)))
480 (widetag (read-byte-arg (fasl-input-stream)))
481 (bits-per-length (aref **saetp-bits-per-length** widetag))
482 (bits (progn (aver (< bits-per-length 255))
483 (* length bits-per-length)))
484 (bytes (ceiling bits sb!vm:n-byte-bits))
485 (words (ceiling bytes sb!vm:n-word-bytes))
486 (vector (if (and (= widetag sb!vm:simple-vector-widetag)
487 (= words 0))
489 (logically-readonlyize
490 (allocate-vector widetag length words)))))
491 (declare (type index length bytes words)
492 (type word bits))
493 (read-n-bytes (fasl-input-stream) vector 0 bytes)
494 vector))
496 (!define-fop 53 (fop-eval (expr)) ; This seems to be unused
497 (if (skip-until)
498 expr
499 (eval expr)))
501 (!define-fop 54 (fop-eval-for-effect (expr) nil) ; This seems to be unused
502 (unless (skip-until)
503 (eval expr))
504 nil)
506 (defun fop-funcall* (input-stream stack skipping)
507 (let ((argc (read-byte-arg input-stream)))
508 (with-fop-stack ((stack) ptr (1+ argc))
509 (unless skipping
510 (do ((i (+ ptr argc))
511 (args))
512 ((= i ptr) (apply (fop-stack-ref i) args))
513 (declare (type index i))
514 (push (fop-stack-ref i) args)
515 (decf i))))))
517 ;; FIXME: there should be a syntax to share these identical bodies
518 (!define-fop 55 (fop-funcall)
519 (fop-funcall* (fasl-input-stream) (operand-stack) (skip-until)))
520 (!define-fop 56 (fop-funcall-for-effect () nil)
521 (fop-funcall* (fasl-input-stream) (operand-stack) (skip-until)))
523 ;;; For LOAD-TIME-VALUE which is used for MAKE-LOAD-FORM
524 (!define-fop 57 (fop-funcall-no-skip)
525 (fop-funcall* (fasl-input-stream) (operand-stack) nil))
527 ;;;; fops for fixing up circularities
529 (!define-fop 200 (fop-rplaca (val) nil)
530 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
531 (idx (read-word-arg (fasl-input-stream))))
532 (setf (car (nthcdr idx obj)) val)))
534 (!define-fop 201 (fop-rplacd (val) nil)
535 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
536 (idx (read-word-arg (fasl-input-stream))))
537 (setf (cdr (nthcdr idx obj)) val)))
539 (!define-fop 202 (fop-svset (val) nil)
540 (let* ((obi (read-word-arg (fasl-input-stream)))
541 (obj (ref-fop-table (fasl-input) obi))
542 (idx (read-word-arg (fasl-input-stream))))
543 (if (%instancep obj) ; suspicious. should have been FOP-STRUCTSET
544 #+sb-xc (setf (%instance-ref obj idx) val)
545 #-sb-xc (bug "%instance-set?")
546 (setf (svref obj idx) val))))
548 (!define-fop 204 :not-host (fop-structset (val) nil)
549 (setf (%instance-ref (ref-fop-table (fasl-input)
550 (read-word-arg (fasl-input-stream)))
551 (read-word-arg (fasl-input-stream)))
552 val))
554 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
555 ;;; to be T, even though that's what it defaults to in DEFINE-FOP.
556 (!define-fop 203 (fop-nthcdr (obj))
557 (nthcdr (read-word-arg (fasl-input-stream)) obj))
559 ;;;; fops for loading functions
561 ;;; (In CMU CL there was a FOP-CODE-FORMAT (47) which was
562 ;;; conventionally placed at the beginning of each fasl file to test
563 ;;; for compatibility between the fasl file and the CMU CL which
564 ;;; loaded it. In SBCL, this functionality has been replaced by
565 ;;; putting the implementation and version in required fields in the
566 ;;; fasl file header.)
568 ;; Cold-load calls COLD-LOAD-CODE instead
569 (!define-fop #xE0 :not-host (fop-code ((:operands n-code-bytes n-boxed-words nfuns)))
570 ;; add 1 word for the toplevel-p flag and one for the debug-info
571 (with-fop-stack ((stack (operand-stack)) ptr (+ n-boxed-words 2))
572 (load-code nfuns n-boxed-words n-code-bytes stack ptr (fasl-input))))
574 ;; this gets you an #<fdefn> object, not the result of (FDEFINITION x)
575 ;; cold-loader uses COLD-FDEFINITION-OBJECT instead.
576 (!define-fop 60 :not-host (fop-fdefn (name))
577 (awhen (deprecated-thing-p 'function name) ; returns the stage of deprecation
578 (pushnew (list* it name :function)
579 (%fasl-input-deprecated-stuff (fasl-input)) :test 'equal))
580 (find-or-create-fdefn name))
582 (!define-fop 65 :not-host (fop-known-fun (name))
583 (%coerce-name-to-fun name))
585 ;;; Modify a slot in a CONSTANTS object.
586 (!define-fop 140 :not-host (fop-alter-code ((:operands index) code value) nil)
587 (setf (code-header-ref code index) value)
588 (values))
590 (!define-fop #xFC :not-host (fop-fun-entry ((:operands fun-index)
591 code-object name arglist type info))
592 (let ((fun (%code-entry-point code-object fun-index)))
593 (setf (%simple-fun-name fun) name)
594 (setf (%simple-fun-arglist fun) arglist)
595 (setf (%simple-fun-type fun) type)
596 (setf (%simple-fun-info fun) info)
597 fun))
599 ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code
600 ;;;; was sufficiently stale that the functions it called were no
601 ;;;; longer defined, so I (William Harold Newman) deleted it.
602 ;;;;
603 ;;;; In case someone in the future is trying to make sense of FOP layout,
604 ;;;; it might be worth recording that the Dylan FOPs were
605 ;;;; 100 FOP-DYLAN-SYMBOL-SAVE
606 ;;;; 101 FOP-SMALL-DYLAN-SYMBOL-SAVE
607 ;;;; 102 FOP-DYLAN-KEYWORD-SAVE
608 ;;;; 103 FOP-SMALL-DYLAN-KEYWORD-SAVE
609 ;;;; 104 FOP-DYLAN-VARINFO-VALUE
611 ;;;; assemblerish fops
613 (!define-fop 144 (fop-assembler-code)
614 (error "cannot load assembler code except at cold load"))
616 ;;; FOPs needed for implementing an IF operator in a FASL
618 ;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is
619 ;;; executed. While skipping, we execute most FOPs normally, except
620 ;;; for ones that a) funcall/eval b) start skipping. This needs to
621 ;;; be done to ensure that the fop table gets populated correctly
622 ;;; regardless of the execution path.
623 (!define-fop 151 (fop-skip (position) nil)
624 (unless (skip-until)
625 (setf (skip-until) position))
626 (values))
628 ;;; As before, but only start skipping if the top of the FOP stack is NIL.
629 (!define-fop 152 (fop-skip-if-false (position condition) nil)
630 (unless (or condition (skip-until))
631 (setf (skip-until) position))
632 (values))
634 ;;; If skipping, pop the top of the stack and discard it. Needed for
635 ;;; ensuring that the stack stays balanced when skipping.
636 (!define-fop 153 (fop-drop-if-skipping () nil)
637 (when (skip-until)
638 (fop-stack-pop-n (operand-stack) 1))
639 (values))
641 ;;; If skipping, push a dummy value on the stack. Needed for
642 ;;; ensuring that the stack stays balanced when skipping.
643 (!define-fop 154 (fop-push-nil-if-skipping () nil)
644 (when (skip-until)
645 (push-fop-stack nil (fasl-input)))
646 (values))
648 ;;; Stop skipping if the top of the stack matches SKIP-UNTIL
649 (!define-fop 155 (fop-maybe-stop-skipping (label) nil)
650 (when (eql (skip-until) label)
651 (setf (skip-until) nil))
652 (values))
654 ;;; Primordial layouts.
655 (macrolet ((frob (&rest specs)
656 `(progn
657 (defun known-layout-fop (name)
658 (case name
659 ,@(mapcar (lambda (spec) `((,(cadr spec)) ,(car spec)))
660 specs)))
661 ,@(mapcar (lambda (spec)
662 `(!define-fop ,(car spec)
663 (,(symbolicate "FOP-LAYOUT-OF-"
664 (cadr spec)))
665 (find-layout ',(cadr spec))))
666 specs))))
667 (frob (#x6c t)
668 (#x6d structure-object)
669 (#x6e condition)
670 (#x6f definition-source-location)
671 (#x70 sb!c::debug-fun)
672 (#x71 sb!c::compiled-debug-fun)
673 (#x72 sb!c::debug-info)
674 (#x73 sb!c::compiled-debug-info)
675 (#x74 sb!c::debug-source)
676 (#x75 defstruct-description)
677 (#x76 defstruct-slot-description)))