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
)
11 `(macrolet ((fop-stack-ref (i)
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
))))
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.
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
))
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
))
38 (:operands
(values (cdar arglist
) (cdr arglist
)))))
39 (assert (<= (length operands
) 2))
40 (values name allowp operands stack-args pushp forms
))))
42 (defun ,name
(.fasl-input.
,@operands
)
43 (declare (ignorable .fasl-input.
))
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
)
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
))))
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 3) n-operands
)) ; 0, 1, or 2 are allowed
65 (let ((n-slots (expt 4 n-operands
)))
66 (unless (zerop (mod base-opcode n-slots
))
67 (error "Opcode for fop ~S must be a multiple of ~D" name n-slots
))
68 (loop for opcode from base-opcode below
(+ base-opcode n-slots
)
69 when
(functionp (svref **fop-funs
** opcode
))
70 do
(let ((oname (svref **fop-names
** opcode
)))
71 (when (and oname
(not (eq oname name
)))
72 (error "fop ~S with opcode ~D conflicts with fop ~S."
74 (let ((existing-opcode (get name
'opcode
)))
75 (when (and existing-opcode
(/= existing-opcode base-opcode
))
76 (error "multiple codes for fop name ~S: ~D and ~D"
77 name base-opcode existing-opcode
)))
78 (setf (get name
'opcode
) base-opcode
)
79 ;; The low 2 bits of the opcode comprise the length modifier if there is
80 ;; exactly one operand. Such opcodes are aligned in blocks of 4.
81 ;; 2-operand fops occupy 16 slots in a reserved range of the function table.
83 (let ((opcode (+ base-opcode j
)))
84 (setf (svref **fop-names
** opcode
) name
85 (svref **fop-funs
** opcode
) (symbol-function name
)
86 (sbit (car **fop-signatures
**) (ash opcode -
2)) (signum n-operands
)
87 (sbit (cdr **fop-signatures
**) opcode
) pushp
))))
90 ;;; a helper function for reading string values from FASL files: sort
91 ;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
92 ;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
93 ;;; for each element read
94 (defun read-string-as-bytes (stream string
&optional
(length (length string
)))
95 (declare (type (simple-array character
(*)) string
)
98 (with-fast-read-byte ((unsigned-byte 8) stream
)
100 (setf (aref string i
)
101 (sb!xc
:code-char
(fast-read-byte)))))
103 (defun read-base-string-as-bytes (stream string
&optional
(length (length string
)))
104 (declare (type (simple-array base-char
(*)) string
)
107 (with-fast-read-byte ((unsigned-byte 8) stream
)
109 (setf (aref string i
)
110 (sb!xc
:code-char
(fast-read-byte)))))
112 #!+(and sb-unicode
(host-feature sb-xc
))
113 (defun read-string-as-unsigned-byte-32
114 (stream string
&optional
(length (length string
)))
115 (declare (type (simple-array character
(*)) string
)
118 (with-fast-read-byte ((unsigned-byte 8) stream
)
120 (setf (aref string i
)
121 (sb!xc
:code-char
(fast-read-u-integer 4)))))
124 ;;;; miscellaneous fops
126 ;;; Setting this variable causes execution of a FOP-NOP4 to produce
127 ;;; output to *DEBUG-IO*. This can be handy when trying to follow the
128 ;;; progress of FASL loading.
130 (defvar *show-fop-nop4-p
* nil
)
132 ;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0
133 ;;; occurs disproportionately often in fasl files for other reasons,
134 ;;; FOP-NOP is less than ideal for writing human-readable patterns
135 ;;; into fasl files for debugging purposes. There's no shortage of
136 ;;; unused fop codes, so we add this second NOP, which reads 4
137 ;;; arbitrary bytes and discards them.
138 (!define-fop
137 (fop-nop4 () nil
)
139 (let ((arg (read-arg 4 (fasl-input-stream))))
140 (declare (ignorable arg
))
142 (when *show-fop-nop4-p
*
143 (format *debug-io
* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg
))))
145 (!define-fop
0 (fop-nop () nil
))
146 (!define-fop
1 (fop-pop (x) nil
) (push-fop-table x
(fasl-input)))
147 (!define-fop
2 (fop-empty-list) nil
)
148 (!define-fop
3 (fop-truth) t
)
149 (!define-fop
4 (fop-push ((:operands index
)))
150 (ref-fop-table (fasl-input) index
))
151 (!define-fop
9 (fop-move-to-table (x))
152 (push-fop-table x
(fasl-input))
155 (!define-fop
66 :not-host
(fop-misc-trap)
156 (%primitive sb
!c
:make-unbound-marker
))
158 (!define-fop
76 (fop-character ((:operands char-code
)))
159 (code-char char-code
))
161 ;; %MAKE-INSTANCE does not exist on the host.
162 (!define-fop
48 :not-host
(fop-struct ((:operands size
) layout
))
163 (let ((res (%make-instance size
)) ; number of words excluding header
164 ;; Discount the layout from number of user-visible words.
165 (n-data-words (- size sb
!vm
:instance-data-start
)))
166 (setf (%instance-layout res
) layout
)
167 (with-fop-stack ((stack (operand-stack)) ptr n-data-words
)
168 (declare (type index ptr
))
169 (let ((bitmap (layout-bitmap layout
)))
170 ;; Values on the stack are in the same order as in the structure itself.
171 (do ((i sb
!vm
:instance-data-start
(1+ i
)))
173 (declare (type index i
))
174 (let ((val (fop-stack-ref ptr
)))
175 (if (logbitp i bitmap
)
176 (setf (%instance-ref res i
) val
)
177 (setf (%raw-instance-ref
/word res i
) val
))
181 (!define-fop
45 (fop-layout (name inherits depthoid length bitmap
))
182 (find-and-init-or-check-layout name length inherits depthoid bitmap
))
184 ;; Allocate a CLOS object. This is used when the compiler detects that
185 ;; MAKE-LOAD-FORM returned a simple use of MAKE-LOAD-FORM-SAVING-SLOTS,
186 ;; or possibly a hand-written equivalent (however unlikely).
187 (!define-fop
68 :not-host
(fop-allocate-instance (name) nil
)
188 (let ((instance (allocate-instance (find-class (the symbol name
)))))
189 (push-fop-table instance
(fasl-input))))
191 ;; Fill in object slots as dictated by the second return value from
192 ;; MAKE-LOAD-FORM-SAVING-SLOTS.
193 ;; This wants a 'count' as the first item in the SLOT-NAMES argument
194 ;; rather than using read-arg because many calls of this might share
195 ;; the list, which must be constructed into the fop-table no matter what.
196 (!define-fop
69 :not-host
(fop-set-slot-values (slot-names obj
) nil
)
197 (let* ((n-slots (pop slot-names
))
198 (stack (operand-stack))
199 (ptr (fop-stack-pop-n stack n-slots
)))
201 (let ((val (svref stack
(+ ptr i
)))
202 (slot-name (pop slot-names
)))
203 (if (eq val sb
!pcl
:+slot-unbound
+)
204 ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
205 (slot-makunbound obj slot-name
)
206 (setf (slot-value obj slot-name
) val
))))))
208 (!define-fop
64 (fop-end-group () nil
)
209 (/show0
"THROWing FASL-GROUP-END")
210 (throw 'fasl-group-end t
))
212 ;;; We used to have FOP-NORMAL-LOAD as 81 and FOP-MAYBE-COLD-LOAD as
213 ;;; 82 until GENESIS learned how to work with host symbols and
214 ;;; packages directly instead of piggybacking on the host code.
216 (!define-fop
62 (fop-verify-table-size () nil
)
217 (let ((expected-index (read-word-arg (fasl-input-stream))))
218 (unless (= (svref (%fasl-input-table
(fasl-input)) 0) expected-index
)
219 (bug "fasl table of improper size"))))
220 (!define-fop
63 (fop-verify-empty-stack () nil
)
221 (unless (fop-stack-empty-p (operand-stack))
222 (bug "fasl stack not empty when it should be")))
224 ;;;; fops for loading symbols
226 (defstruct (undefined-package (:copier nil
))
227 (error nil
:read-only t
))
228 (declaim (freeze-type undefined-package
))
230 ;; Cold load has its own implementation of all symbol fops,
231 ;; but we have to execute define-fop now to assign their numbers.
232 (labels #+sb-xc-host
()
234 ((read-symbol-name (length+flag fasl-input
)
235 (let* ((namelen (ash (the fixnum length
+flag
) -
1))
236 (base-p (logand length
+flag
1))
237 (elt-type (if (eql base-p
1) 'base-char
'character
))
238 (buffer (%fasl-input-name-buffer fasl-input
))
239 (string (the string
(svref buffer base-p
))))
240 (when (< (length string
) namelen
) ; grow
241 (setf string
(make-string namelen
:element-type elt-type
)
242 (svref buffer base-p
) string
))
243 (funcall (if (eql base-p
1)
244 'read-base-string-as-bytes
245 'read-string-as-unsigned-byte-32
)
246 (%fasl-input-stream fasl-input
) string namelen
)
247 (values string namelen elt-type
)))
248 (aux-fop-intern (length+flag package fasl-input
)
249 (multiple-value-bind (name length elt-type
)
250 (read-symbol-name length
+flag fasl-input
)
251 (if (undefined-package-p package
)
252 (error 'simple-package-error
253 :format-control
"Error finding package for symbol ~s:~% ~a"
255 (list (subseq name
0 length
)
256 (undefined-package-error package
)))
257 (push-fop-table (without-package-locks
258 (%intern name length package elt-type
))
260 ;; Symbol-hash is usually computed lazily and memoized into a symbol.
261 ;; Laziness slightly improves the speed of allocation.
262 ;; But when loading fasls, the time spent in the loader totally swamps
263 ;; any time savings of not precomputing symbol-hash.
264 ;; INTERN hashes everything anyway, so let's be consistent
265 ;; and precompute the hashes of uninterned symbols too.
266 (ensure-hashed (symbol)
267 (ensure-symbol-hash symbol
)
270 #-sb-xc-host
(declare (inline ensure-hashed
))
271 (!define-fop
80 :not-host
(fop-lisp-symbol-save ((:operands length
+flag
)))
272 (aux-fop-intern length
+flag
*cl-package
* (fasl-input)))
273 (!define-fop
84 :not-host
(fop-keyword-symbol-save ((:operands length
+flag
)))
274 (aux-fop-intern length
+flag
*keyword-package
* (fasl-input)))
275 (!define-fop
#xF0
:not-host
(fop-symbol-in-package-save ((:operands pkg-index length
+flag
)))
276 (aux-fop-intern length
+flag
(ref-fop-table (fasl-input) pkg-index
) (fasl-input)))
278 (!define-fop
96 :not-host
(fop-uninterned-symbol-save ((:operands length
+flag
)))
279 (multiple-value-bind (name len
) (read-symbol-name length
+flag
(fasl-input))
280 (push-fop-table (ensure-hashed (make-symbol (subseq name
0 len
)))
283 (!define-fop
104 :not-host
(fop-copy-symbol-save ((:operands table-index
)))
284 (push-fop-table (ensure-hashed
285 (copy-symbol (ref-fop-table (fasl-input) table-index
)))
288 (!define-fop
44 (fop-package (pkg-designator))
289 (find-undeleted-package-or-lose pkg-designator
))
291 (!define-fop
156 :not-host
(fop-named-package-save ((:operands length
)) nil
)
292 (let ((package-name (make-string length
)))
293 #!-sb-unicode
(read-string-as-bytes (fasl-input-stream) package-name
)
294 #!+sb-unicode
(read-string-as-unsigned-byte-32 (fasl-input-stream) package-name
)
296 (handler-case (find-undeleted-package-or-lose package-name
)
297 (simple-package-error (c)
298 (make-undefined-package :error
(princ-to-string c
))))
301 ;;;; fops for loading numbers
303 ;;; Load a signed integer LENGTH bytes long from FASL-INPUT-STREAM.
304 (defun load-s-integer (length fasl-input-stream
)
305 (declare (fixnum length
)
307 (with-fast-read-byte ((unsigned-byte 8) fasl-input-stream
)
308 (do* ((index length
(1- index
))
309 (byte 0 (fast-read-byte))
310 (result 0 (+ result
(ash byte bits
)))
313 (if (logbitp 7 byte
) ; look at sign bit
314 (- result
(ash 1 bits
))
316 (declare (fixnum index byte bits
)))))
318 (!define-fop
36 (fop-integer ((:operands n-bytes
)))
319 (load-s-integer n-bytes
(fasl-input-stream)))
321 (!define-fop
34 (fop-word-integer)
322 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
323 (fast-read-s-integer #.sb
!vm
:n-word-bytes
)))
325 (!define-fop
35 (fop-byte-integer)
326 ;; FIXME: WITH-FAST-READ-BYTE for exactly 1 byte is not really faster/better
327 ;; than regular READ-BYTE. The expansion of READ-ARG corroborates this claim.
328 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
329 (fast-read-s-integer 1)))
331 ;; No %MAKE-RATIO on host
332 (!define-fop
70 :not-host
(fop-ratio (num den
)) (%make-ratio num den
))
334 ;; No %MAKE-COMPLEX on host
335 (!define-fop
71 :not-host
(fop-complex (realpart imagpart
))
336 (%make-complex realpart imagpart
))
338 (macrolet ((fast-read-single-float ()
339 '(make-single-float (fast-read-s-integer 4)))
340 (fast-read-double-float ()
341 '(let ((lo (fast-read-u-integer 4)))
342 (make-double-float (fast-read-s-integer 4) lo
))))
343 (macrolet ((define-complex-fop (opcode name type
)
344 (let ((reader (symbolicate "FAST-READ-" type
)))
345 `(!define-fop
,opcode
(,name
)
346 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
347 (complex (,reader
) (,reader
))))))
348 (define-float-fop (opcode name type
)
349 (let ((reader (symbolicate "FAST-READ-" type
)))
350 `(!define-fop
,opcode
(,name
)
351 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
353 (define-complex-fop 72 fop-complex-single-float single-float
)
354 (define-complex-fop 73 fop-complex-double-float double-float
)
356 (define-complex-fop 67 fop-complex-long-float long-float
)
357 (define-float-fop 46 fop-single-float single-float
)
358 (define-float-fop 47 fop-double-float double-float
)
360 (define-float-fop 52 fop-long-float long-float
)))
363 (!define-fop
88 (fop-simd-pack)
364 (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
365 (%make-simd-pack
(fast-read-s-integer 8)
366 (fast-read-u-integer 8)
367 (fast-read-u-integer 8))))
371 (defun fop-list-from-stack (stack n
)
372 ;; N is 0-255 when called from FOP-LIST,
373 ;; but it is as large as ARRAY-RANK-LIMIT in FOP-ARRAY.
374 (declare (type (unsigned-byte 16) n
)
375 (optimize (speed 3)))
376 (with-fop-stack ((stack) ptr n
)
377 (do* ((i (+ ptr n
) (1- i
))
378 (res () (cons (fop-stack-ref i
) res
)))
380 (declare (type index i
)))))
382 (!define-fop
33 (fop-list)
383 (fop-list-from-stack (operand-stack) (read-byte-arg (fasl-input-stream))))
384 (!define-fop
16 (fop-list*)
385 ;; N is the number of cons cells (0 is ok)
386 (let ((n (read-byte-arg (fasl-input-stream))))
387 (with-fop-stack ((stack (operand-stack)) ptr
(1+ n
))
388 (do* ((i (+ ptr n
) (1- i
))
389 (res (fop-stack-ref (+ ptr n
))
390 (cons (fop-stack-ref i
) res
)))
392 (declare (type index i
))))))
394 (macrolet ((frob (name op fun n
)
395 (let ((args (make-gensym-list n
)))
396 `(!define-fop
,op
(,name
,args
) (,fun
,@args
)))))
398 (frob fop-list-1
17 list
1)
399 (frob fop-list-2
18 list
2)
400 (frob fop-list-3
19 list
3)
401 (frob fop-list-4
20 list
4)
402 (frob fop-list-5
21 list
5)
403 (frob fop-list-6
22 list
6)
404 (frob fop-list-7
23 list
7)
405 (frob fop-list-8
24 list
8)
407 (frob fop-list
*-
1 25 list
* 2)
408 (frob fop-list
*-
2 26 list
* 3)
409 (frob fop-list
*-
3 27 list
* 4)
410 (frob fop-list
*-
4 28 list
* 5)
411 (frob fop-list
*-
5 29 list
* 6)
412 (frob fop-list
*-
6 30 list
* 7)
413 (frob fop-list
*-
7 31 list
* 8)
414 (frob fop-list
*-
8 32 list
* 9))
416 ;;;; fops for loading arrays
418 (!define-fop
100 (fop-base-string ((:operands length
)))
419 (read-base-string-as-bytes (fasl-input-stream)
420 (make-string length
:element-type
'base-char
)))
422 ;; FIXME: can save space by UTF-8 encoding, or use 1 bit to indicate pure ASCII
423 ;; in the fasl even though the result will be a non-base string.
425 (!define-fop
160 :not-host
(fop-character-string ((:operands length
)))
426 (read-string-as-unsigned-byte-32 (fasl-input-stream)
427 (make-string length
)))
429 (!define-fop
92 (fop-vector ((:operands size
)))
430 (let ((res (make-array size
))
431 (stack (operand-stack)))
432 (declare (fixnum size
))
434 (let ((ptr (fop-stack-pop-n stack size
)))
435 (replace res stack
:start2 ptr
)))
438 ;; No MAKE-ARRAY-HEADER on host
439 (!define-fop
89 :not-host
(fop-array (vec))
440 (let* ((rank (read-word-arg (fasl-input-stream)))
441 (length (length vec
))
442 (res (make-array-header sb
!vm
:simple-array-widetag rank
)))
443 (declare (simple-array vec
)
444 (type (unsigned-byte #.
(- sb
!vm
:n-word-bits sb
!vm
:n-widetag-bits
)) rank
))
445 (set-array-header res vec length nil
0
446 (fop-list-from-stack (operand-stack) rank
)
450 (defglobal **saetp-bits-per-length
**
451 (let ((array (make-array (1+ sb
!vm
:widetag-mask
)
452 :element-type
'(unsigned-byte 8)
453 :initial-element
255)))
454 (loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
456 (setf (aref array
(sb!vm
:saetp-typecode saetp
))
457 (sb!vm
:saetp-n-bits saetp
)))
460 "255 means bad entry.")
461 (declaim (type (simple-array (unsigned-byte 8) (#.
(1+ sb
!vm
:widetag-mask
)))
462 **saetp-bits-per-length
**))
464 ;; No ALLOCATE-VECTOR on host (nor READ-N-BYTES)
465 (!define-fop
43 :not-host
(fop-spec-vector)
466 (let* ((length (read-word-arg (fasl-input-stream)))
467 (widetag (read-byte-arg (fasl-input-stream)))
468 (bits-per-length (aref **saetp-bits-per-length
** widetag
))
469 (bits (progn (aver (< bits-per-length
255))
470 (* length bits-per-length
)))
471 (bytes (ceiling bits sb
!vm
:n-byte-bits
))
472 (words (ceiling bytes sb
!vm
:n-word-bytes
))
473 (vector (allocate-vector widetag length words
)))
474 (declare (type index length bytes words
)
476 (read-n-bytes (fasl-input-stream) vector
0 bytes
)
479 (!define-fop
53 (fop-eval (expr)) ; This seems to be unused
484 (!define-fop
54 (fop-eval-for-effect (expr) nil
) ; This seems to be unused
489 (defun fop-funcall* (input-stream stack skipping
)
490 (let ((argc (read-byte-arg input-stream
)))
491 (with-fop-stack ((stack) ptr
(1+ argc
))
493 (do ((i (+ ptr argc
))
495 ((= i ptr
) (apply (fop-stack-ref i
) args
))
496 (declare (type index i
))
497 (push (fop-stack-ref i
) args
)
500 ;; FIXME: there should be a syntax to share these identical bodies
501 (!define-fop
55 (fop-funcall)
502 (fop-funcall* (fasl-input-stream) (operand-stack) (skip-until)))
503 (!define-fop
56 (fop-funcall-for-effect () nil
)
504 (fop-funcall* (fasl-input-stream) (operand-stack) (skip-until)))
506 ;;;; fops for fixing up circularities
508 (!define-fop
200 (fop-rplaca (val) nil
)
509 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
510 (idx (read-word-arg (fasl-input-stream))))
511 (setf (car (nthcdr idx obj
)) val
)))
513 (!define-fop
201 (fop-rplacd (val) nil
)
514 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
515 (idx (read-word-arg (fasl-input-stream))))
516 (setf (cdr (nthcdr idx obj
)) val
)))
518 (!define-fop
202 (fop-svset (val) nil
)
519 (let* ((obi (read-word-arg (fasl-input-stream)))
520 (obj (ref-fop-table (fasl-input) obi
))
521 (idx (read-word-arg (fasl-input-stream))))
522 (if (%instancep obj
) ; suspicious. should have been FOP-STRUCTSET
523 #+sb-xc
(setf (%instance-ref obj idx
) val
)
524 #-sb-xc
(bug "%instance-set?")
525 (setf (svref obj idx
) val
))))
527 (!define-fop
204 :not-host
(fop-structset (val) nil
)
528 (setf (%instance-ref
(ref-fop-table (fasl-input)
529 (read-word-arg (fasl-input-stream)))
530 (read-word-arg (fasl-input-stream)))
533 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
534 ;;; to be T, even though that's what it defaults to in DEFINE-FOP.
535 (!define-fop
203 (fop-nthcdr (obj))
536 (nthcdr (read-word-arg (fasl-input-stream)) obj
))
538 ;;;; fops for loading functions
540 ;;; (In CMU CL there was a FOP-CODE-FORMAT (47) which was
541 ;;; conventionally placed at the beginning of each fasl file to test
542 ;;; for compatibility between the fasl file and the CMU CL which
543 ;;; loaded it. In SBCL, this functionality has been replaced by
544 ;;; putting the implementation and version in required fields in the
545 ;;; fasl file header.)
547 ;; Cold-load calls COLD-LOAD-CODE instead
548 (!define-fop
#xE0
:not-host
(fop-code ((:operands n-boxed-words n-unboxed-bytes
)))
549 ;; add 1 word for the toplevel-p flag and one for the debug-info
550 (with-fop-stack ((stack (operand-stack)) ptr
(+ n-boxed-words
2))
551 (load-code n-boxed-words n-unboxed-bytes stack ptr
(fasl-input-stream))))
553 ;; this gets you an #<fdefn> object, not the result of (FDEFINITION x)
554 ;; cold-loader uses COLD-FDEFINITION-OBJECT instead.
555 (!define-fop
60 :not-host
(fop-fdefn (name))
556 (awhen (deprecated-thing-p 'function name
) ; returns the stage of deprecation
557 (pushnew (list* it name
:function
)
558 (%fasl-input-deprecated-stuff
(fasl-input)) :test
'equal
))
559 (find-or-create-fdefn name
))
561 (!define-fop
65 :not-host
(fop-known-fun (name))
562 (%coerce-name-to-fun name
))
565 (!define-fop
61 :not-host
(fop-sanctify-for-execution (component))
566 (sb!vm
:sanctify-for-execution component
)
569 (!define-fop
174 (fop-note-debug-source (debug-source) nil
)
570 (warn "~@<FOP-NOTE-DEBUG-SOURCE seen in ordinary load (not cold load) -- ~
571 very strange! If you didn't do something to cause this, please report it as ~
573 ;; we are going to be lenient with coming across this fop in a warm SBCL.
574 (setf (sb!c
::debug-source-compiled debug-source
) (get-universal-time)
575 (sb!c
::debug-source-created debug-source
)
576 (file-write-date (sb!c
::debug-source-namestring debug-source
))))
578 ;;; Modify a slot in a CONSTANTS object.
579 (!define-fop
140 :not-host
(fop-alter-code ((:operands index
) code value
) nil
)
580 (setf (code-header-ref code index
) value
)
583 (!define-fop
139 :not-host
(fop-fun-entry (code-object name arglist type info
))
584 (let ((offset (read-word-arg (fasl-input-stream))))
585 (declare (type index offset
))
586 (unless (zerop (logand offset sb
!vm
:lowtag-mask
))
587 (bug "unaligned function object, offset = #X~X" offset
))
588 (let ((fun (%primitive sb
!c
:compute-fun code-object offset
)))
589 (setf (%simple-fun-self fun
) fun
)
590 (setf (%simple-fun-next fun
) (%code-entry-points code-object
))
591 (setf (%code-entry-points code-object
) fun
)
592 (setf (%simple-fun-name fun
) name
)
593 (setf (%simple-fun-arglist fun
) arglist
)
594 (setf (%simple-fun-type fun
) type
)
595 (setf (%simple-fun-info fun
) info
)
598 ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code
599 ;;;; was sufficiently stale that the functions it called were no
600 ;;;; longer defined, so I (William Harold Newman) deleted it.
602 ;;;; In case someone in the future is trying to make sense of FOP layout,
603 ;;;; it might be worth recording that the Dylan FOPs were
604 ;;;; 100 FOP-DYLAN-SYMBOL-SAVE
605 ;;;; 101 FOP-SMALL-DYLAN-SYMBOL-SAVE
606 ;;;; 102 FOP-DYLAN-KEYWORD-SAVE
607 ;;;; 103 FOP-SMALL-DYLAN-KEYWORD-SAVE
608 ;;;; 104 FOP-DYLAN-VARINFO-VALUE
610 ;;;; assemblerish fops
612 (!define-fop
144 (fop-assembler-code)
613 (error "cannot load assembler code except at cold load"))
615 (!define-fop
145 (fop-assembler-routine)
616 (error "cannot load assembler code except at cold load"))
618 (!define-fop
146 :not-host
(fop-symbol-tls-fixup (code-object kind symbol
))
619 (sb!vm
:fixup-code-object code-object
620 (read-word-arg (fasl-input-stream))
621 (ensure-symbol-tls-index symbol
)
626 (!define-fop
135 :not-host
(fop-static-call-fixup (code-object kind name
))
627 (sb!vm
:fixup-code-object code-object
628 (read-word-arg (fasl-input-stream))
629 (sb!vm
::function-raw-address name
)
633 (!define-fop
147 :not-host
(fop-foreign-fixup (code-object kind
))
634 (let* ((len (read-byte-arg (fasl-input-stream)))
635 (sym (make-string len
:element-type
'base-char
)))
636 (read-n-bytes (fasl-input-stream) sym
0 len
)
637 (sb!vm
:fixup-code-object code-object
638 (read-word-arg (fasl-input-stream))
639 (foreign-symbol-address sym
)
643 (!define-fop
148 :not-host
(fop-assembler-fixup (code-object kind routine
))
644 (multiple-value-bind (value found
) (gethash routine
*assembler-routines
*)
646 (error "undefined assembler routine: ~S" routine
))
647 (sb!vm
:fixup-code-object code-object
(read-word-arg (fasl-input-stream))
651 (!define-fop
149 :not-host
(fop-code-object-fixup (code-object kind
))
652 ;; Note: We don't have to worry about GC moving the code-object after
653 ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because
654 ;; we can only use code-object fixups when code-objects don't move.
655 (sb!vm
:fixup-code-object code-object
(read-word-arg (fasl-input-stream))
656 (get-lisp-obj-address code-object
) kind
)
660 (!define-fop
150 :not-host
(fop-foreign-dataref-fixup (code-object kind
))
661 (let* ((len (read-byte-arg (fasl-input-stream)))
662 (sym (make-string len
:element-type
'base-char
)))
663 (read-n-bytes (fasl-input-stream) sym
0 len
)
664 (sb!vm
:fixup-code-object code-object
665 (read-word-arg (fasl-input-stream))
666 (foreign-symbol-address sym t
)
670 ;;; FOPs needed for implementing an IF operator in a FASL
672 ;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is
673 ;;; executed. While skipping, we execute most FOPs normally, except
674 ;;; for ones that a) funcall/eval b) start skipping. This needs to
675 ;;; be done to ensure that the fop table gets populated correctly
676 ;;; regardless of the execution path.
677 (!define-fop
151 (fop-skip (position) nil
)
679 (setf (skip-until) position
))
682 ;;; As before, but only start skipping if the top of the FOP stack is NIL.
683 (!define-fop
152 (fop-skip-if-false (position condition
) nil
)
684 (unless (or condition
(skip-until))
685 (setf (skip-until) position
))
688 ;;; If skipping, pop the top of the stack and discard it. Needed for
689 ;;; ensuring that the stack stays balanced when skipping.
690 (!define-fop
153 (fop-drop-if-skipping () nil
)
692 (fop-stack-pop-n (operand-stack) 1))
695 ;;; If skipping, push a dummy value on the stack. Needed for
696 ;;; ensuring that the stack stays balanced when skipping.
697 (!define-fop
154 (fop-push-nil-if-skipping () nil
)
699 (push-fop-stack nil
(fasl-input)))
702 ;;; Stop skipping if the top of the stack matches SKIP-UNTIL
703 (!define-fop
155 (fop-maybe-stop-skipping (label) nil
)
704 (when (eql (skip-until) label
)
705 (setf (skip-until) nil
))
708 ;;; Primordial layouts.
709 ;;; At the rate the opcode space is filling up, it might be wise to
710 ;;; rethink using 16 each for FOP-CODE and -SYMBOL-IN-PACKAGE-SAVE.
711 (macrolet ((frob (&rest specs
)
713 (defun known-layout-fop (name)
715 ,@(mapcar (lambda (spec) `((,(cadr spec
)) ,(car spec
)))
717 ,@(mapcar (lambda (spec)
718 `(!define-fop
,(car spec
)
719 (,(symbolicate "FOP-LAYOUT-OF-"
721 (find-layout ',(cadr spec
))))
724 (#x6d structure-object
)
725 (#x6f definition-source-location
)
726 (#x70 sb
!c
::debug-fun
)
727 (#x71 sb
!c
::compiled-debug-fun
)
728 (#x72 sb
!c
::debug-info
)
729 (#x73 sb
!c
::compiled-debug-info
)
730 (#x74 sb
!c
::debug-source
)
731 (#x75 defstruct-description
)
732 (#x76 defstruct-slot-description
)))