5 ;;; Sometimes we want to skip over any FOPs with side-effects (like
6 ;;; function calls) while executing other FOPs. *SKIP-UNTIL* will
7 ;;; either contain the position where the skipping will stop, or
8 ;;; NIL if we're executing normally.
9 (defvar *skip-until
* nil
)
11 ;;; Bind STACK-VAR and PTR-VAR to the start of a subsequence of
12 ;;; the fop stack of length COUNT, then execute BODY.
13 ;;; Within the body, FOP-STACK-REF is used in lieu of SVREF
14 ;;; to elide bounds checking.
15 (defmacro with-fop-stack
((stack-var ptr-var count
) &body body
)
16 `(multiple-value-bind (,stack-var
,ptr-var
)
17 (truly-the (values simple-vector index
) (fop-stack-pop-n ,count
))
18 (macrolet ((fop-stack-ref (i)
21 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
22 (svref ,',stack-var
(truly-the index
,i
)))))
25 ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP
26 ;;; describes what the body does to the fop stack:
28 ;;; The body might pop the fop stack. The result of the body is
29 ;;; pushed on the fop stack.
31 ;;; The body might pop the fop stack. The result of the body is
34 (defmacro !define-fop
(fop-code (name &optional arglist
(pushp t
)) &body forms
)
35 (aver (member pushp
'(nil t
)))
36 (multiple-value-bind (operands stack-args
)
37 (if (consp (car arglist
))
39 (:operands
(values (cdar arglist
) (cdr arglist
))))
41 (assert (<= (length operands
) 2))
43 (defun ,name
,operands
44 ,@(if (null stack-args
)
46 (with-unique-names (stack ptr
)
47 `((with-fop-stack (,stack
,ptr
,(length stack-args
))
48 (multiple-value-bind ,stack-args
49 (values ,@(loop for i below
(length stack-args
)
50 collect
`(fop-stack-ref (+ ,ptr
,i
))))
52 (!%define-fop
',name
,fop-code
,(length operands
) ,(if pushp
1 0)))))
54 (defun !%define-fop
(name base-opcode n-operands pushp
)
55 (declare (type (mod 3) n-operands
)) ; 0, 1, or 2 are allowed
56 (let ((n-slots (expt 4 n-operands
)))
57 (unless (zerop (mod base-opcode n-slots
))
58 (error "Opcode for fop ~S must be a multiple of ~D" name n-slots
))
59 (loop for opcode from base-opcode below
(+ base-opcode n-slots
)
60 when
(functionp (svref *fop-funs
* opcode
))
61 do
(let ((oname (svref *fop-names
* opcode
)))
62 (when (and oname
(not (eq oname name
)))
63 (error "fop ~S with opcode ~D conflicts with fop ~S."
65 (let ((existing-opcode (get name
'opcode
)))
66 (when (and existing-opcode
(/= existing-opcode base-opcode
))
67 (error "multiple codes for fop name ~S: ~D and ~D"
68 name base-opcode existing-opcode
)))
69 (setf (get name
'opcode
) base-opcode
)
70 ;; The low 2 bits of the opcode comprise the length modifier if there is
71 ;; exactly one operand. Such opcodes are aligned in blocks of 4.
72 ;; 2-operand fops occupy 16 slots in a reserved range of the function table.
74 (let ((opcode (+ base-opcode j
)))
75 (setf (svref *fop-names
* opcode
) name
76 (svref *fop-funs
* opcode
) (symbol-function name
)
77 (sbit (car *fop-signatures
*) (ash opcode -
2)) (signum n-operands
)
78 (sbit (cdr *fop-signatures
*) opcode
) pushp
))))
81 ;;; a helper function for reading string values from FASL files: sort
82 ;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
83 ;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
84 ;;; for each element read
85 (defun read-string-as-bytes (stream string
&optional
(length (length string
)))
86 (declare (type (simple-array character
(*)) string
)
89 (with-fast-read-byte ((unsigned-byte 8) stream
)
92 (sb!xc
:code-char
(fast-read-byte)))))
94 (defun read-base-string-as-bytes (stream string
&optional
(length (length string
)))
95 (declare (type (simple-array base-char
(*)) string
)
98 (with-fast-read-byte ((unsigned-byte 8) stream
)
100 (setf (aref string i
)
101 (sb!xc
:code-char
(fast-read-byte)))))
104 (defun read-string-as-unsigned-byte-32
105 (stream string
&optional
(length (length string
)))
106 (declare (type (simple-array character
(*)) string
)
109 #+sb-xc-host
(bug "READ-STRING-AS-UNSIGNED-BYTE-32 called")
110 (with-fast-read-byte ((unsigned-byte 8) stream
)
112 (setf (aref string i
)
113 (sb!xc
:code-char
(fast-read-u-integer 4)))))
116 ;;;; miscellaneous fops
118 ;;; Setting this variable causes execution of a FOP-NOP4 to produce
119 ;;; output to *DEBUG-IO*. This can be handy when trying to follow the
120 ;;; progress of FASL loading.
122 (defvar *show-fop-nop4-p
* nil
)
124 ;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0
125 ;;; occurs disproportionately often in fasl files for other reasons,
126 ;;; FOP-NOP is less than ideal for writing human-readable patterns
127 ;;; into fasl files for debugging purposes. There's no shortage of
128 ;;; unused fop codes, so we add this second NOP, which reads 4
129 ;;; arbitrary bytes and discards them.
130 (!define-fop
137 (fop-nop4 () nil
)
131 (let ((arg (read-arg 4)))
132 (declare (ignorable arg
))
134 (when *show-fop-nop4-p
*
135 (format *debug-io
* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg
))))
137 (!define-fop
0 (fop-nop () nil
))
138 (!define-fop
1 (fop-pop (x) nil
) (push-fop-table x
))
139 (!define-fop
2 (fop-empty-list) nil
)
140 (!define-fop
3 (fop-truth) t
)
141 (!define-fop
4 (fop-push ((:operands index
))) (ref-fop-table index
))
143 ;;; CMU CL had FOP-POP-FOR-EFFECT as fop 65, but it was never used and seemed
144 ;;; to have no possible use.
145 (!define-fop
66 (fop-misc-trap)
146 #+sb-xc-host
; since xc host doesn't know how to compile %PRIMITIVE
147 (error "FOP-MISC-TRAP can't be defined without %PRIMITIVE.")
149 (%primitive sb
!c
:make-unbound-marker
))
151 (!define-fop
76 (fop-character ((:operands char-code
)))
152 (code-char char-code
))
154 (!define-fop
48 (fop-struct ((:operands size
) layout
))
155 (let* ((res (%make-instance size
)) ; number of words excluding header
156 ;; Compute count of elements to pop from stack, sans layout.
157 ;; If instance-data-start is 0, then size is the count,
158 ;; otherwise subtract 1 because the layout consumes a slot.
159 (n-data-words (- size sb
!vm
:instance-data-start
)))
160 (declare (type index size
))
161 (with-fop-stack (stack ptr n-data-words
)
162 (let ((ptr (+ ptr n-data-words
)))
163 (declare (type index ptr
))
164 (setf (%instance-layout res
) layout
)
165 #!-interleaved-raw-slots
166 (let* ((nuntagged (layout-n-untagged-slots layout
))
167 (ntagged (- size nuntagged
)))
168 (dotimes (n (1- ntagged
))
169 (declare (type index n
))
170 (setf (%instance-ref res
(1+ n
)) (fop-stack-ref (decf ptr
))))
171 (dotimes (n nuntagged
)
172 (declare (type index n
))
173 (setf (%raw-instance-ref
/word res
(- nuntagged n
1))
174 (fop-stack-ref (decf ptr
)))))
175 #!+interleaved-raw-slots
176 (let ((metadata (layout-untagged-bitmap layout
)))
177 (do ((i sb
!vm
:instance-data-start
(1+ i
)))
179 (declare (type index i
))
180 (let ((val (fop-stack-ref (decf ptr
))))
181 (if (logbitp i metadata
)
182 (setf (%raw-instance-ref
/word res i
) val
)
183 (setf (%instance-ref res i
) val
)))))))
186 (!define-fop
45 (fop-layout (name inherits depthoid length metadata
))
187 (find-and-init-or-check-layout name length inherits depthoid metadata
))
189 ;; Allocate a CLOS object. This is used when the compiler detects that
190 ;; MAKE-LOAD-FORM returned a simple use of MAKE-LOAD-FORM-SAVING-SLOTS,
191 ;; or possibly a hand-written equivalent (however unlikely).
192 (!define-fop
68 (fop-allocate-instance (name) nil
)
193 (let ((instance (allocate-instance (find-class (the symbol name
)))))
194 (push-fop-table instance
)))
196 ;; Fill in object slots as dictated by the second return value from
197 ;; MAKE-LOAD-FORM-SAVING-SLOTS.
198 ;; This wants a 'count' as the first item in the SLOT-NAMES argument
199 ;; rather than using read-arg because many calls of this might share
200 ;; the list, which must be constructed into the fop-table no matter what.
201 (!define-fop
69 (fop-initialize-instance (slot-names obj
) nil
)
202 (let ((n-slots (pop slot-names
)))
203 (multiple-value-bind (stack ptr
) (fop-stack-pop-n n-slots
)
205 (let ((val (svref stack
(+ ptr i
)))
206 (slot-name (pop slot-names
)))
207 (if (eq val
'sb
!pcl
::..slot-unbound..
)
208 ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
209 (slot-makunbound obj slot-name
)
210 ;; FIXME: the DEFSETF for this isn't defined until warm load
211 (sb!pcl
::set-slot-value obj slot-name val
)))))))
213 (!define-fop
64 (fop-end-group () nil
)
214 (/show0
"THROWing FASL-GROUP-END")
215 (throw 'fasl-group-end t
))
217 ;;; We used to have FOP-NORMAL-LOAD as 81 and FOP-MAYBE-COLD-LOAD as
218 ;;; 82 until GENESIS learned how to work with host symbols and
219 ;;; packages directly instead of piggybacking on the host code.
221 (!define-fop
62 (fop-verify-table-size () nil
)
222 (let ((expected-index (read-word-arg)))
223 (unless (= (get-fop-table-index) expected-index
)
224 (bug "fasl table of improper size"))))
225 (!define-fop
63 (fop-verify-empty-stack () nil
)
226 (unless (fop-stack-empty-p)
227 (bug "fasl stack not empty when it should be")))
229 ;;;; fops for loading symbols
231 (defstruct (undefined-package
235 (declaim (freeze-type undefined-package
))
237 (defun aux-fop-intern (size package
)
238 (declare (optimize speed
))
239 (let ((buffer (make-string size
)))
241 (read-string-as-bytes *fasl-input-stream
* buffer size
)
245 (read-string-as-unsigned-byte-32 *fasl-input-stream
* buffer size
)
247 (read-string-as-bytes *fasl-input-stream
* buffer size
))
248 (if (undefined-package-p package
)
249 (error 'simple-package-error
250 :format-control
"Error finding package for symbol ~s:~% ~a"
252 (list (subseq buffer
0 size
)
253 (undefined-package-error package
)))
254 (push-fop-table (without-package-locks
260 (!define-fop
80 (fop-lisp-symbol-save ((:operands namelen
)))
261 (aux-fop-intern namelen
*cl-package
*))
262 (!define-fop
84 (fop-keyword-symbol-save ((:operands namelen
)))
263 (aux-fop-intern namelen
*keyword-package
*))
265 ;; But srsly? Most of the space is wasted by UCS4 encoding of ASCII.
266 ;; An extra word per symbol for the package is nothing by comparison.
267 ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an
268 ;; enormous number of symbols will fall through to this case,
269 ;; probably resulting in bloated fasl files. A new
270 ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE
271 ;; cloned fop pair could undo some of this bloat.
272 (!define-fop
#xF0
(fop-symbol-in-package-save ((:operands pkg-index namelen
)))
273 (aux-fop-intern namelen
(ref-fop-table pkg-index
)))
275 (!define-fop
96 (fop-uninterned-symbol-save ((:operands namelen
)))
276 (let ((res (make-string namelen
)))
278 (read-string-as-bytes *fasl-input-stream
* res
)
280 (read-string-as-unsigned-byte-32 *fasl-input-stream
* res
)
281 (push-fop-table (make-symbol res
))))
283 (!define-fop
104 (fop-copy-symbol-save ((:operands table-index
)))
284 (push-fop-table (copy-symbol (ref-fop-table table-index
))))
286 (!define-fop
44 (fop-package (pkg-designator))
287 (find-undeleted-package-or-lose pkg-designator
))
289 (!define-fop
156 (fop-named-package-save ((:operands length
)) nil
)
290 (let ((package-name (make-string length
)))
292 (read-string-as-bytes *fasl-input-stream
* package-name
)
296 (read-string-as-bytes *fasl-input-stream
* package-name
)
298 (read-string-as-unsigned-byte-32 *fasl-input-stream
* package-name
))
300 (handler-case (find-undeleted-package-or-lose package-name
)
301 (simple-package-error (c)
302 (make-undefined-package :error
(princ-to-string c
)))))))
304 ;;;; fops for loading numbers
306 ;;; Load a signed integer LENGTH bytes long from *FASL-INPUT-STREAM*.
307 (defun load-s-integer (length)
308 (declare (fixnum length
)
310 (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
311 (do* ((index length
(1- index
))
312 (byte 0 (fast-read-byte))
313 (result 0 (+ result
(ash byte bits
)))
316 (if (logbitp 7 byte
) ; look at sign bit
317 (- result
(ash 1 bits
))
319 (declare (fixnum index byte bits
)))))
321 (!define-fop
36 (fop-integer ((:operands n-bytes
)))
322 (load-s-integer n-bytes
))
324 (!define-fop
34 (fop-word-integer)
325 (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
326 (fast-read-s-integer #.sb
!vm
:n-word-bytes
)))
328 (!define-fop
35 (fop-byte-integer)
329 (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
330 (fast-read-s-integer 1)))
332 (!define-fop
70 (fop-ratio (num den
)) (%make-ratio num den
))
334 (!define-fop
71 (fop-complex (realpart imagpart
))
335 (%make-complex realpart imagpart
))
337 (macrolet ((fast-read-single-float ()
338 '(make-single-float (fast-read-s-integer 4)))
339 (fast-read-double-float ()
340 '(let ((lo (fast-read-u-integer 4)))
341 (make-double-float (fast-read-s-integer 4) lo
))))
342 (macrolet ((define-complex-fop (opcode name type
)
343 (let ((reader (symbolicate "FAST-READ-" type
)))
344 `(!define-fop
,opcode
(,name
)
345 (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
346 (complex (,reader
) (,reader
))))))
347 (define-float-fop (opcode name type
)
348 (let ((reader (symbolicate "FAST-READ-" type
)))
349 `(!define-fop
,opcode
(,name
)
350 (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
352 (define-complex-fop 72 fop-complex-single-float single-float
)
353 (define-complex-fop 73 fop-complex-double-float double-float
)
355 (define-complex-fop 67 fop-complex-long-float long-float
)
356 (define-float-fop 46 fop-single-float single-float
)
357 (define-float-fop 47 fop-double-float double-float
)
359 (define-float-fop 52 fop-long-float long-float
)))
362 (!define-fop
88 (fop-simd-pack)
363 (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream
*)
364 (%make-simd-pack
(fast-read-s-integer 8)
365 (fast-read-u-integer 8)
366 (fast-read-u-integer 8))))
370 (defun fop-list-from-stack (n)
371 ;; N is 0-255 when called from FOP-LIST,
372 ;; but it is as large as ARRAY-RANK-LIMIT in FOP-ARRAY.
373 (declare (type (unsigned-byte 16) n
)
374 (optimize (speed 3)))
375 (with-fop-stack (stack ptr n
)
376 (do* ((i (+ ptr n
) (1- i
))
377 (res () (cons (fop-stack-ref i
) res
)))
379 (declare (type index i
)))))
381 (!define-fop
33 (fop-list) (fop-list-from-stack (read-byte-arg)))
382 (!define-fop
16 (fop-list*)
383 (let ((n (read-byte-arg))) ; N is the number of cons cells (0 is ok)
384 (with-fop-stack (stack ptr
(1+ n
))
385 (do* ((i (+ ptr n
) (1- i
))
386 (res (fop-stack-ref (+ ptr n
))
387 (cons (fop-stack-ref i
) res
)))
389 (declare (type index i
))))))
391 (macrolet ((frob (name op fun n
)
392 (let ((args (make-gensym-list n
)))
393 `(!define-fop
,op
(,name
,args
) (,fun
,@args
)))))
395 (frob fop-list-1
17 list
1)
396 (frob fop-list-2
18 list
2)
397 (frob fop-list-3
19 list
3)
398 (frob fop-list-4
20 list
4)
399 (frob fop-list-5
21 list
5)
400 (frob fop-list-6
22 list
6)
401 (frob fop-list-7
23 list
7)
402 (frob fop-list-8
24 list
8)
404 (frob fop-list
*-
1 25 list
* 2)
405 (frob fop-list
*-
2 26 list
* 3)
406 (frob fop-list
*-
3 27 list
* 4)
407 (frob fop-list
*-
4 28 list
* 5)
408 (frob fop-list
*-
5 29 list
* 6)
409 (frob fop-list
*-
6 30 list
* 7)
410 (frob fop-list
*-
7 31 list
* 8)
411 (frob fop-list
*-
8 32 list
* 9))
413 ;;;; fops for loading arrays
415 (!define-fop
100 (fop-base-string ((:operands length
)))
416 (let ((res (make-string length
:element-type
'base-char
)))
417 (read-base-string-as-bytes *fasl-input-stream
* res
)
421 ;; FIXME: can save space by UTF-8 encoding, or use 1 bit to indicate pure ASCII
422 ;; in the fasl even though the result will be a non-base string.
425 (!define-fop
160 (fop-character-string ((:operands length
)))
426 (bug "CHARACTER-STRING FOP encountered"))
429 (!define-fop
160 (fop-character-string ((:operands length
)))
430 (let ((res (make-string length
)))
431 (read-string-as-unsigned-byte-32 *fasl-input-stream
* res
)
434 (!define-fop
92 (fop-vector ((:operands size
)))
435 (let ((res (make-array size
)))
436 (declare (fixnum size
))
438 (multiple-value-bind (stack ptr
) (fop-stack-pop-n size
)
439 (replace res stack
:start2 ptr
)))
442 (!define-fop
89 (fop-array (vec))
443 (let* ((rank (read-word-arg))
444 (length (length vec
))
445 (res (make-array-header sb
!vm
:simple-array-widetag rank
)))
446 (declare (simple-array vec
)
447 (type (unsigned-byte #.
(- sb
!vm
:n-word-bits sb
!vm
:n-widetag-bits
)) rank
))
448 (set-array-header res vec length nil
0 (fop-list-from-stack rank
) nil t
)
451 (defglobal **saetp-bits-per-length
**
452 (let ((array (make-array (1+ sb
!vm
:widetag-mask
)
453 :element-type
'(unsigned-byte 8)
454 :initial-element
255)))
455 (loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
457 (setf (aref array
(sb!vm
:saetp-typecode saetp
))
458 (sb!vm
:saetp-n-bits saetp
)))
461 "255 means bad entry.")
462 (declaim (type (simple-array (unsigned-byte 8) (#.
(1+ sb
!vm
:widetag-mask
)))
463 **saetp-bits-per-length
**))
465 (!define-fop
43 (fop-spec-vector)
466 (let* ((length (read-word-arg))
467 (widetag (read-byte-arg))
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* ()
490 (let ((argc (read-byte-arg)))
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 (!define-fop
55 (fop-funcall) (fop-funcall*))
501 (!define-fop
56 (fop-funcall-for-effect () nil
) (fop-funcall*))
503 ;;;; fops for fixing up circularities
505 (!define-fop
200 (fop-rplaca (val) nil
)
506 (let ((obj (ref-fop-table (read-word-arg)))
507 (idx (read-word-arg)))
508 (setf (car (nthcdr idx obj
)) val
)))
510 (!define-fop
201 (fop-rplacd (val) nil
)
511 (let ((obj (ref-fop-table (read-word-arg)))
512 (idx (read-word-arg)))
513 (setf (cdr (nthcdr idx obj
)) val
)))
515 (!define-fop
202 (fop-svset (val) nil
)
516 (let* ((obi (read-word-arg))
517 (obj (ref-fop-table obi
))
518 (idx (read-word-arg)))
519 (if (%instancep obj
) ; suspicious. should have been FOP-STRUCTSET
520 (setf (%instance-ref obj idx
) val
)
521 (setf (svref obj idx
) val
))))
523 (!define-fop
204 (fop-structset (val) nil
)
524 (setf (%instance-ref
(ref-fop-table (read-word-arg))
528 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
529 ;;; to be T, even though that's what it defaults to in DEFINE-FOP.
530 (!define-fop
203 (fop-nthcdr (obj))
531 (nthcdr (read-word-arg) obj
))
533 ;;;; fops for loading functions
535 ;;; (In CMU CL there was a FOP-CODE-FORMAT (47) which was
536 ;;; conventionally placed at the beginning of each fasl file to test
537 ;;; for compatibility between the fasl file and the CMU CL which
538 ;;; loaded it. In SBCL, this functionality has been replaced by
539 ;;; putting the implementation and version in required fields in the
540 ;;; fasl file header.)
542 (!define-fop
#xE0
(fop-code ((:operands n-boxed-words n-unboxed-bytes
)))
543 (load-code n-boxed-words n-unboxed-bytes
))
545 ;; this gets you an #<fdefn> object, not the result of (FDEFINITION x)
546 (!define-fop
60 (fop-fdefn (name))
547 (find-or-create-fdefn name
))
549 (!define-fop
65 (fop-known-fun (name))
550 (%coerce-name-to-fun name
))
553 (!define-fop
61 (fop-sanctify-for-execution (component))
554 (sb!vm
:sanctify-for-execution component
)
557 (!define-fop
74 (fop-fset (name fn
) nil
)
558 ;; Ordinary, not-for-cold-load code shouldn't need to mess with this
559 ;; at all, since it's only used as part of the conspiracy between
560 ;; the cross-compiler and GENESIS to statically link FDEFINITIONs
562 (warn "~@<FOP-FSET seen in ordinary load (not cold load) -- quite strange! ~
563 If you didn't do something strange to cause this, please report it as a ~
565 ;; Unlike CMU CL, we don't treat this as a no-op in ordinary code.
566 ;; If the user (or, more likely, developer) is trying to reload
567 ;; compiled-for-cold-load code into a warm SBCL, we'll do a warm
568 ;; assignment. (This is partly for abstract tidiness, since the warm
569 ;; assignment is the closest analogy to what happens at cold load,
570 ;; and partly because otherwise our compiled-for-cold-load code will
571 ;; fail, since in SBCL things like compiled-for-cold-load %DEFUN
572 ;; depend more strongly than in CMU CL on FOP-FSET actually doing
574 (setf (fdefinition name
) fn
))
576 (!define-fop
174 (fop-note-debug-source (debug-source) nil
)
577 (warn "~@<FOP-NOTE-DEBUG-SOURCE seen in ordinary load (not cold load) -- ~
578 very strange! If you didn't do something to cause this, please report it as ~
580 ;; as with COLD-FSET above, we are going to be lenient with coming
581 ;; across this fop in a warm SBCL.
582 (setf (sb!c
::debug-source-compiled debug-source
) (get-universal-time)
583 (sb!c
::debug-source-created debug-source
)
584 (file-write-date (sb!c
::debug-source-namestring debug-source
))))
586 ;;; Modify a slot in a CONSTANTS object.
587 (!define-fop
140 (fop-alter-code ((:operands index
) code value
) nil
)
588 (setf (code-header-ref code index
) value
)
591 (!define-fop
139 (fop-fun-entry (code-object name arglist type info
))
592 #+sb-xc-host
; since xc host doesn't know how to compile %PRIMITIVE
593 (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.")
595 (let ((offset (read-word-arg)))
596 (declare (type index offset
))
597 (unless (zerop (logand offset sb
!vm
:lowtag-mask
))
598 (bug "unaligned function object, offset = #X~X" offset
))
599 (let ((fun (%primitive sb
!c
:compute-fun code-object offset
)))
600 (setf (%simple-fun-self fun
) fun
)
601 (setf (%simple-fun-next fun
) (%code-entry-points code-object
))
602 (setf (%code-entry-points code-object
) fun
)
603 (setf (%simple-fun-name fun
) name
)
604 (setf (%simple-fun-arglist fun
) arglist
)
605 (setf (%simple-fun-type fun
) type
)
606 (setf (%simple-fun-info fun
) info
)
609 ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code
610 ;;;; was sufficiently stale that the functions it called were no
611 ;;;; longer defined, so I (William Harold Newman) deleted it.
613 ;;;; In case someone in the future is trying to make sense of FOP layout,
614 ;;;; it might be worth recording that the Dylan FOPs were
615 ;;;; 100 FOP-DYLAN-SYMBOL-SAVE
616 ;;;; 101 FOP-SMALL-DYLAN-SYMBOL-SAVE
617 ;;;; 102 FOP-DYLAN-KEYWORD-SAVE
618 ;;;; 103 FOP-SMALL-DYLAN-KEYWORD-SAVE
619 ;;;; 104 FOP-DYLAN-VARINFO-VALUE
621 ;;;; assemblerish fops
623 (!define-fop
144 (fop-assembler-code)
624 (error "cannot load assembler code except at cold load"))
626 (!define-fop
145 (fop-assembler-routine)
627 (error "cannot load assembler code except at cold load"))
629 (!define-fop
146 (fop-symbol-tls-fixup (code-object kind symbol
))
630 (sb!vm
:fixup-code-object code-object
632 (ensure-symbol-tls-index symbol
)
636 (!define-fop
147 (fop-foreign-fixup (code-object kind
))
637 (let* ((len (read-byte-arg))
638 (sym (make-string len
:element-type
'base-char
)))
639 (read-n-bytes *fasl-input-stream
* sym
0 len
)
640 (sb!vm
:fixup-code-object code-object
642 (foreign-symbol-address sym
)
646 (!define-fop
148 (fop-assembler-fixup (code-object kind routine
))
647 (multiple-value-bind (value found
) (gethash routine
*assembler-routines
*)
649 (error "undefined assembler routine: ~S" routine
))
650 (sb!vm
:fixup-code-object code-object
(read-word-arg) value kind
))
653 (!define-fop
149 (fop-code-object-fixup (code-object kind
))
654 ;; Note: We don't have to worry about GC moving the code-object after
655 ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because
656 ;; we can only use code-object fixups when code-objects don't move.
657 (sb!vm
:fixup-code-object code-object
(read-word-arg)
658 (get-lisp-obj-address code-object
) kind
)
662 (!define-fop
150 (fop-foreign-dataref-fixup (code-object kind
))
663 (let* ((len (read-byte-arg))
664 (sym (make-string len
:element-type
'base-char
)))
665 (read-n-bytes *fasl-input-stream
* sym
0 len
)
666 (sb!vm
:fixup-code-object code-object
668 (foreign-symbol-address sym t
)
672 ;;; FOPs needed for implementing an IF operator in a FASL
674 ;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is
675 ;;; executed. While skipping, we execute most FOPs normally, except
676 ;;; for ones that a) funcall/eval b) start skipping. This needs to
677 ;;; be done to ensure that the fop table gets populated correctly
678 ;;; regardless of the execution path.
679 (!define-fop
151 (fop-skip (position) nil
)
681 (setf *skip-until
* position
))
684 ;;; As before, but only start skipping if the top of the FOP stack is NIL.
685 (!define-fop
152 (fop-skip-if-false (position condition
) nil
)
686 (unless (or condition
*skip-until
*)
687 (setf *skip-until
* position
))
690 ;;; If skipping, pop the top of the stack and discard it. Needed for
691 ;;; ensuring that the stack stays balanced when skipping.
692 (!define-fop
153 (fop-drop-if-skipping () nil
)
697 ;;; If skipping, push a dummy value on the stack. Needed for
698 ;;; ensuring that the stack stays balanced when skipping.
699 (!define-fop
154 (fop-push-nil-if-skipping () nil
)
701 (push-fop-stack nil
))
704 ;;; Stop skipping if the top of the stack matches *SKIP-UNTIL*
705 (!define-fop
155 (fop-maybe-stop-skipping (label) nil
)
706 (when (eql *skip-until
* label
)
707 (setf *skip-until
* nil
))