/[cmucl]/src/code/byte-interp.lisp
ViewVC logotype

Contents of /src/code/byte-interp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (show annotations)
Tue Apr 20 17:57:43 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.48: +12 -12 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/byte-interp.lisp,v 1.49 2010/04/20 17:57:43 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the noise to interpret byte-compiled stuff.
13 ;;;
14 ;;; Written by William Lott
15 ;;;
16 (in-package "C")
17
18 (in-package "KERNEL")
19
20 (intl:textdomain "cmucl")
21
22 (export '(byte-function byte-function-name initialize-byte-compiled-function
23 byte-closure byte-closure-function
24 byte-closure-data byte-function-or-closure
25 byte-function-type
26 *eval-stack* *eval-stack-top*))
27 (in-package "C")
28
29 ;;; We need at least this level of debug-info in order for the local
30 ;;; declaration in with-debugger-info to take effect.
31 ;;;
32 (declaim (optimize (debug 2)))
33
34
35 ;;;; Types.
36
37 (deftype stack-pointer ()
38 `(integer 0 ,(1- most-positive-fixnum)))
39
40 (defconstant max-pc (1- (ash 1 24)))
41
42 (deftype pc ()
43 `(integer 0 ,max-pc))
44
45 (deftype return-pc ()
46 `(integer ,(- max-pc) ,max-pc))
47
48
49 ;;; These dummies are defined here, to make a build without compiler
50 ;;; work.
51
52 (defun %dynamic-extent (kind sp)
53 (declare (ignore kind sp)))
54
55 (defun %dynamic-extent-start ())
56
57 (defun %dynamic-extent-end (kind sp)
58 (declare (ignore kind sp)))
59
60
61 ;;;; Byte functions:
62
63 ;;; Abstract class represents any type of byte-compiled function.
64 ;;;
65 (defstruct (byte-function-or-closure
66 (:alternate-metaclass kernel:funcallable-instance
67 kernel:funcallable-structure-class
68 kernel:make-funcallable-structure-class)
69 (:type kernel:funcallable-structure)))
70
71 ;;; Represents a byte-compiled closure.
72 ;;;
73 (defstruct (byte-closure
74 (:include byte-function-or-closure)
75 (:constructor make-byte-closure (function data))
76 (:type kernel:funcallable-structure)
77 (:print-function
78 (lambda (s stream d)
79 (declare (ignore d))
80 (print-unreadable-object (s stream :identity t)
81 (format stream "Byte closure ~S"
82 (byte-function-name (byte-closure-function s)))))))
83 ;;
84 ;; Byte function that we call.
85 (function (required-argument) :type byte-function)
86 ;;
87 ;; Closure data vector.
88 (data (required-argument) :type simple-vector))
89
90
91 ;;; Any non-closure byte function (including the hidden function object for a
92 ;;; closure.)
93 ;;;
94 (defstruct (byte-function (:include byte-function-or-closure)
95 (:print-function %print-byte-function)
96 (:type kernel:funcallable-structure))
97 ;;
98 ;; The component that this XEP is an entry point into. NIL until
99 ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. They count on this being
100 ;; the first slot.
101 (component nil :type (or null kernel:code-component))
102 ;;
103 ;; Debug name of this function.
104 (name nil))
105
106 ;;; Fixed-argument byte function.
107 ;;;
108 (defstruct (simple-byte-function (:include byte-function)
109 (:type kernel:funcallable-structure))
110 ;;
111 ;; The number of arguments expected.
112 (num-args 0 :type (integer 0 #.call-arguments-limit))
113 ;;
114 ;; The start of the function.
115 (entry-point 0 :type index))
116
117
118 ;;; Variable arg-count byte function.
119 ;;;
120 (defstruct (hairy-byte-function (:include byte-function)
121 (:type kernel:funcallable-structure))
122 ;;
123 ;; The minimum and maximum number of args, ignoring &rest and &key.
124 (min-args 0 :type (integer 0 #.call-arguments-limit))
125 (max-args 0 :type (integer 0 #.call-arguments-limit))
126 ;;
127 ;; List of the entry points for min-args, min-args+1, ... max-args.
128 (entry-points nil :type list)
129 ;;
130 ;; The entry point to use when there are more than max-args. Only filled
131 ;; in where okay. In other words, only when &rest or &key is specified.
132 (more-args-entry-point nil :type (or null (unsigned-byte 24)))
133 ;;
134 ;; The number of ``more-arg'' args.
135 (num-more-args 0 :type (integer 0 #.call-arguments-limit))
136 ;;
137 ;; True if there is a rest-arg, :MORE if there is &MORE.
138 (rest-arg-p nil :type (member t nil :more))
139 ;;
140 ;; True if there are keywords. Note: keywords might still be NIL because
141 ;; having &key with no keywords is valid and should result in
142 ;; allow-other-keys processing. If :allow-others, then allow other keys.
143 (keywords-p nil :type (member t nil :allow-others))
144 ;;
145 ;; List of keyword arguments. Each element is a list of:
146 ;; key, default, supplied-p.
147 (keywords nil :type list))
148
149 (defun %print-byte-function (s stream d)
150 (declare (ignore d))
151 (print-unreadable-object (s stream :identity t)
152 (format stream "Byte function ~S" (byte-function-name s))))
153
154 (declaim (freeze-type byte-function-or-closure))
155
156
157 ;;; BYTE-FUNCTION-TYPE -- Interface
158 ;;;
159 ;;; Return a function type approximating the type of a byte compiled
160 ;;; function. We really only capture the arg signature.
161 ;;;
162 (defun byte-function-type (x)
163 (specifier-type
164 (etypecase x
165 (simple-byte-function
166 `(function ,(make-list (simple-byte-function-num-args x)
167 :initial-element 't)
168 *))
169 (hairy-byte-function
170 (collect ((res))
171 (let ((min (hairy-byte-function-min-args x))
172 (max (hairy-byte-function-max-args x)))
173 (dotimes (i min) (res 't))
174 (when (> max min)
175 (res '&optional)
176 (dotimes (i (- max min))
177 (res 't))))
178 (when (hairy-byte-function-rest-arg-p x)
179 (res '&rest 't))
180 (ecase (hairy-byte-function-keywords-p x)
181 ((t :allow-others)
182 (res '&key)
183 (dolist (key (hairy-byte-function-keywords x))
184 (res `(,(car key) t)))
185 (if (eql (hairy-byte-function-keywords-p x) :allow-others)
186 (res '&allow-other-keys)))
187 ((nil)))
188 `(function ,(res) *))))))
189
190
191 ;;;; The stack.
192
193 (defvar *eval-stack* (make-array 100)
194 "This is the interpreter's evaluation stack.")
195 (declaim (type simple-vector *eval-stack*))
196
197 (defvar *eval-stack-top* 0
198 "This is the next free element of the interpreter's evaluation stack.")
199 (declaim (type index *eval-stack-top*))
200
201 (defmacro current-stack-pointer () '*eval-stack-top*)
202
203 (declaim (inline eval-stack-ref))
204 (defun eval-stack-ref (offset)
205 (declare (type stack-pointer offset))
206 (svref eval::*eval-stack* offset))
207
208 (declaim (inline (setf eval-stack-ref)))
209 (defun (setf eval-stack-ref) (new-value offset)
210 (declare (type stack-pointer offset))
211 (setf (svref eval::*eval-stack* offset) new-value))
212
213 (defun push-eval-stack (value)
214 (let ((len (length (the simple-vector eval::*eval-stack*)))
215 (sp (current-stack-pointer)))
216 (when (= len sp)
217 (let ((new-stack (make-array (ash len 1))))
218 (replace new-stack eval::*eval-stack* :end1 len :end2 len)
219 (setf eval::*eval-stack* new-stack)))
220 (setf (current-stack-pointer) (1+ sp))
221 (setf (eval-stack-ref sp) value)))
222
223 (defun allocate-eval-stack (amount)
224 (let* ((len (length (the simple-vector eval::*eval-stack*)))
225 (sp (current-stack-pointer))
226 (new-sp (+ sp amount)))
227 (declare (type index sp new-sp))
228 (when (>= new-sp len)
229 (let ((new-stack (make-array (ash new-sp 1))))
230 (replace new-stack eval::*eval-stack* :end1 len :end2 len)
231 (setf eval::*eval-stack* new-stack)))
232 (setf (current-stack-pointer) new-sp)
233 (let ((stack eval::*eval-stack*))
234 (do ((i sp (1+ i)))
235 ((= i new-sp))
236 (setf (svref stack i) '#:uninitialized))))
237 (undefined-value))
238
239 (defun pop-eval-stack ()
240 (let* ((new-sp (1- (current-stack-pointer)))
241 (value (eval-stack-ref new-sp)))
242 (setf (current-stack-pointer) new-sp)
243 value))
244
245 (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
246 (declare (optimize (inhibit-warnings 3)))
247 (let ((num-vars (length vars))
248 (index -1)
249 (new-sp-var (gensym "NEW-SP-"))
250 (decls nil))
251 (loop
252 (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare))
253 (return))
254 (push (pop body) decls))
255 `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars)))
256 (declare (type stack-pointer ,new-sp-var))
257 (let ,(mapcar #'(lambda (var)
258 `(,var (eval-stack-ref
259 (+ ,new-sp-var ,(incf index)))))
260 vars)
261 ,@(nreverse decls)
262 (setf (current-stack-pointer) ,new-sp-var)
263 ,@body))))
264
265 (defun stack-copy (dest src count)
266 (declare (type stack-pointer dest src count))
267 (let ((stack *eval-stack*))
268 (if (< dest src)
269 (dotimes (i count)
270 (setf (svref stack dest) (svref stack src))
271 (incf dest)
272 (incf src))
273 (do ((si (1- (+ src count))
274 (1- si))
275 (di (1- (+ dest count))
276 (1- di)))
277 ((< si src))
278 (declare (fixnum si di))
279 (setf (svref stack di) (svref stack si)))))
280 (undefined-value))
281
282
283 ;;;; Component access magic.
284
285 (declaim (inline component-ref))
286 (defun component-ref (component pc)
287 (declare (type code-component component)
288 (type pc pc))
289 (system:sap-ref-8 (code-instructions component) pc))
290
291 (declaim (inline (setf component-ref)))
292 (defun (setf component-ref) (value component pc)
293 (declare (type (unsigned-byte 8) value)
294 (type code-component component)
295 (type pc pc))
296 (setf (system:sap-ref-8 (code-instructions component) pc) value))
297
298 (declaim (inline component-ref-signed))
299 (defun component-ref-signed (component pc)
300 (let ((byte (component-ref component pc)))
301 (if (logbitp 7 byte)
302 (logior (ash -1 8) byte)
303 byte)))
304
305 (declaim (inline component-ref-24))
306 (defun component-ref-24 (component pc)
307 (logior (ash (component-ref component pc) 16)
308 (ash (component-ref component (1+ pc)) 8)
309 (component-ref component (+ pc 2))))
310
311
312 ;;;; Debugging support.
313
314 ;;; WITH-DEBUGGER-INFO -- internal.
315 ;;;
316 ;;; This macro binds three magic variables. When the debugger notices that
317 ;;; these three variables are bound, it makes a byte-code frame out of the
318 ;;; supplied information instead of a compiled frame. We set each var in
319 ;;; addition to binding it so the compiler doesn't optimize away the binding.
320 ;;;
321 (defmacro with-debugger-info ((component pc fp) &body body)
322 `(let ((%byte-interp-component ,component)
323 (%byte-interp-pc ,pc)
324 (%byte-interp-fp ,fp))
325 (declare (optimize (debug 3)))
326 (setf %byte-interp-component %byte-interp-component)
327 (setf %byte-interp-pc %byte-interp-pc)
328 (setf %byte-interp-fp %byte-interp-fp)
329 ,@body))
330
331
332 (defun byte-install-breakpoint (component pc)
333 (declare (type code-component component)
334 (type pc pc)
335 (values (unsigned-byte 8)))
336 (let ((orig (component-ref component pc)))
337 (setf (component-ref component pc)
338 #.(logior byte-xop
339 (xop-index-or-lose 'breakpoint)))
340 orig))
341
342 (defun byte-remove-breakpoint (component pc orig)
343 (declare (type code-component component)
344 (type pc pc)
345 (type (unsigned-byte 8) orig)
346 (values (unsigned-byte 8)))
347 (setf (component-ref component pc) orig))
348
349 (defun byte-skip-breakpoint (component pc fp orig)
350 (declare (type code-component component)
351 (type pc pc)
352 (type stack-pointer fp)
353 (type (unsigned-byte 8) orig))
354 (byte-interpret-byte component fp pc orig))
355
356
357
358
359 ;;;; System constants
360
361 ;;; A table mapping system constant indices to run-time values. We don't
362 ;;; reference the compiler variable at load time, since the interpreter is
363 ;;; loaded first.
364 ;;;
365 (defparameter system-constants
366 (let ((res (make-array 256)))
367 (dolist (x '#.(collect ((res))
368 (do-hash (key value *system-constant-codes*)
369 (res (cons key value)))
370 (res)))
371 (let ((key (car x))
372 (value (cdr x)))
373 (setf (svref res value)
374 (if (and (consp key) (eq (car key) '%fdefinition-marker%))
375 (lisp::fdefinition-object (cdr key) t)
376 key))))
377 res))
378
379
380 ;;;; Byte compiled function constructors/extractors.
381
382 (defun initialize-byte-compiled-function (xep)
383 (declare (type byte-function xep))
384 (push xep (code-header-ref (byte-function-component xep)
385 vm:code-trace-table-offset-slot))
386 (setf (funcallable-instance-function xep)
387 #'(instance-lambda (&more context count)
388 (let ((old-sp (current-stack-pointer)))
389 (declare (type stack-pointer old-sp))
390 (dotimes (i count)
391 (push-eval-stack (%more-arg context i)))
392 (invoke-xep nil 0 old-sp 0 count xep))))
393 xep)
394
395 (defun make-byte-compiled-closure (xep closure-vars)
396 (declare (type byte-function xep)
397 (type simple-vector closure-vars))
398 (let ((res (make-byte-closure xep closure-vars)))
399 (setf (funcallable-instance-function res)
400 #'(instance-lambda (&more context count)
401 (let ((old-sp (current-stack-pointer)))
402 (declare (type stack-pointer old-sp))
403 (dotimes (i count)
404 (push-eval-stack (%more-arg context i)))
405 (invoke-xep nil 0 old-sp 0 count
406 (byte-closure-function res)
407 (byte-closure-data res)))))
408 res))
409
410
411 ;;;; Inlines.
412
413 (eval-when (compile eval)
414 (setq ext:*inline-expansion-limit* 400))
415
416 (defmacro expand-into-inlines ()
417 (declare (optimize (inhibit-warnings 3)))
418 (iterate build-dispatch
419 ((bit 4)
420 (base 0))
421 (if (minusp bit)
422 (let ((info (svref *inline-functions* base)))
423 (if info
424 (let* ((spec (type-specifier
425 (inline-function-info-type info)))
426 (arg-types (second spec))
427 (result-type (third spec))
428 (args (mapcar #'(lambda (x)
429 (declare (ignore x))
430 (gensym))
431 arg-types))
432 (func
433 `(the ,result-type
434 (,(inline-function-info-interpreter-function info)
435 ,@args))))
436 `(multiple-value-pop-eval-stack ,args
437 (declare ,@(mapcar #'(lambda (type var)
438 `(type ,type ,var))
439 arg-types args))
440 ,(if (and (consp result-type)
441 (eq (car result-type) 'values))
442 (let ((results
443 (mapcar #'(lambda (x)
444 (declare (ignore x))
445 (gensym))
446 (cdr result-type))))
447 `(multiple-value-bind
448 ,results ,func
449 ,@(mapcar #'(lambda (res)
450 `(push-eval-stack ,res))
451 results)))
452 `(push-eval-stack ,func))))
453 `(error (intl:gettext "Unknown inline function, id=~D") ,base)))
454 `(if (zerop (logand byte ,(ash 1 bit)))
455 ,(build-dispatch (1- bit) base)
456 ,(build-dispatch (1- bit) (+ base (ash 1 bit)))))))
457
458
459 (declaim (inline value-cell-setf))
460 (defun value-cell-setf (value cell)
461 (value-cell-set cell value)
462 value)
463
464 (declaim (inline setf-symbol-value))
465 (defun setf-symbol-value (value symbol)
466 (setf (symbol-value symbol) value))
467
468 (declaim (inline %setf-instance-ref))
469 (defun %setf-instance-ref (new-value instance index)
470 (setf (%instance-ref instance index) new-value))
471
472 (eval-when (compile)
473
474 (defmacro %byte-symbol-value (x)
475 `(let ((x ,x))
476 (unless (boundp x)
477 (with-debugger-info (component pc fp)
478 (error (intl:gettext "Unbound variable: ~S") x)))
479 (symbol-value x)))
480
481 (defmacro %byte-car (x)
482 `(let ((x ,x))
483 (unless (listp x)
484 (with-debugger-info (component pc fp)
485 (error 'simple-type-error :datum x :expected-type 'list
486 :format-control (intl:gettext "Non-list argument to CAR: ~S")
487 :format-arguments (list x))))
488 (car x)))
489
490 (defmacro %byte-cdr (x)
491 `(let ((x ,x))
492 (unless (listp x)
493 (with-debugger-info (component pc fp)
494 (error 'simple-type-error :datum x :expected-type 'list
495 :format-control (intl:gettext "Non-list argument to CDR: ~S")
496 :format-arguments (list x))))
497 (cdr x)))
498
499 ); eval-when (compile)
500
501 (declaim (inline %byte-special-bind))
502 (defun %byte-special-bind (value symbol)
503 (system:%primitive bind value symbol)
504 (values))
505
506 (declaim (inline %byte-special-unbind))
507 (defun %byte-special-unbind ()
508 (system:%primitive unbind)
509 (values))
510
511 ;;; obsolete...
512 (declaim (inline cons-unique-tag))
513 (defun cons-unique-tag ()
514 (list '#:%unique-tag%))
515
516
517 ;;;; Two-arg function stubs:
518 ;;;
519 ;;; We have two-arg versions of some n-ary functions that are normally
520 ;;; open-coded.
521
522 (defun two-arg-char= (x y) (char= x y))
523 (defun two-arg-char< (x y) (char< x y))
524 (defun two-arg-char> (x y) (char> x y))
525 (defun two-arg-char-equal (x y) (char-equal x y))
526 (defun two-arg-char-lessp (x y) (char-lessp x y))
527 (defun two-arg-char-greaterp (x y) (char-greaterp x y))
528 (defun two-arg-string= (x y) (string= x y))
529 (defun two-arg-string< (x y) (string< x y))
530 (defun two-arg-string> (x y) (string> x y))
531
532
533 ;;;; Misc primitive stubs:
534
535 (macrolet ((frob (name &optional (args '(x)))
536 `(defun ,name ,args (,name ,@args))))
537 (frob %CODE-CODE-SIZE)
538 (frob %CODE-DEBUG-INFO)
539 (frob %CODE-ENTRY-POINTS)
540 (frob %FUNCALLABLE-INSTANCE-FUNCTION)
541 (frob %FUNCALLABLE-INSTANCE-LAYOUT)
542 (frob %FUNCALLABLE-INSTANCE-LEXENV)
543 (frob %FUNCTION-NEXT)
544 (frob %FUNCTION-SELF)
545 (frob %SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-val))
546 (frob %SXHASH-SIMPLE-SUBSTRING (str count)))
547
548
549 ;;;; Funny functions:
550
551 ;;; used by both byte and IR1 interpreters.
552 ;;;
553 (defun %progv (vars vals fun)
554 (progv vars vals
555 (funcall fun)))
556
557
558 ;;;; XOPs
559
560 ;;; Extension operations (XOPs) are random magic things that the byte
561 ;;; interpreter needs to do, but can't be represented as a function call.
562 ;;; When the byte interpreter encounters an XOP in the byte stream, it
563 ;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
564 ;;; The XOP routine can do whatever it wants, probably re-invoking the
565 ;;; byte interpreter.
566
567 ;;; Fetch an 8/24 bit operand out of the code stream.
568 ;;;
569 (eval-when (compile eval)
570 (defmacro with-extended-operand ((component pc operand new-pc)
571 &body body)
572 (once-only ((n-component component)
573 (n-pc pc))
574 `(multiple-value-bind
575 (,operand ,new-pc)
576 (let ((,operand (component-ref ,n-component ,n-pc)))
577 (if (= ,operand #xff)
578 (values (component-ref-24 ,n-component (1+ ,n-pc))
579 (+ ,n-pc 4))
580 (values ,operand (1+ ,n-pc))))
581 (declare (type index ,operand ,new-pc))
582 ,@body))))
583
584
585 ;;; UNDEFINED-XOP -- internal.
586 ;;;
587 ;;; If a real XOP hasn't been defined, this gets invoked and signals an
588 ;;; error. This shouldn't happen in normal operation.
589 ;;;
590 (defun undefined-xop (component old-pc pc fp)
591 (declare (ignore component old-pc pc fp))
592 (error (intl:gettext "Undefined XOP.")))
593
594 ;;; *BYTE-XOPS* -- Simple vector of the XOP functions.
595 ;;;
596 (declaim (type (simple-vector 256) *byte-xops*))
597 (defvar *byte-xops*
598 (make-array 256 :initial-element #'undefined-xop))
599
600 ;;; DEFINE-XOP -- internal.
601 ;;;
602 ;;; Define a XOP function and install it in *BYTE-XOPS*.
603 ;;;
604 (eval-when (compile eval)
605 (defmacro define-xop (name lambda-list &body body)
606 (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
607 `(progn
608 (defun ,defun-name ,lambda-list
609 ,@body)
610 (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
611 ',defun-name))))
612
613 ;;; BREAKPOINT -- Xop.
614 ;;;
615 ;;; This is spliced in by the debugger in order to implement breakpoints.
616 ;;;
617 (define-xop breakpoint (component old-pc pc fp)
618 (declare (type code-component component)
619 (type pc old-pc)
620 (ignore pc)
621 (type stack-pointer fp))
622 ;; Invoke the debugger.
623 (with-debugger-info (component old-pc fp)
624 (di::handle-breakpoint component old-pc fp))
625 ;; Retry the breakpoint XOP in case it was replaced with the original
626 ;; displaced byte-code.
627 (byte-interpret component old-pc fp))
628
629 ;;; DUP -- Xop.
630 ;;;
631 ;;; This just duplicates whatever is on the top of the stack.
632 ;;;
633 (define-xop dup (component old-pc pc fp)
634 (declare (type code-component component)
635 (ignore old-pc)
636 (type pc pc)
637 (type stack-pointer fp))
638 (let ((value (eval-stack-ref (1- (current-stack-pointer)))))
639 (push-eval-stack value))
640 (byte-interpret component pc fp))
641
642 ;;; MAKE-CLOSURE -- Xop.
643 ;;;
644 (define-xop make-closure (component old-pc pc fp)
645 (declare (type code-component component)
646 (ignore old-pc)
647 (type pc pc)
648 (type stack-pointer fp))
649 (let* ((num-closure-vars (pop-eval-stack))
650 (closure-vars (make-array num-closure-vars)))
651 (declare (type index num-closure-vars)
652 (type simple-vector closure-vars))
653 (iterate frob ((index (1- num-closure-vars)))
654 (unless (minusp index)
655 (setf (svref closure-vars index) (pop-eval-stack))
656 (frob (1- index))))
657 (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
658 closure-vars)))
659 (byte-interpret component pc fp))
660
661 (define-xop merge-unknown-values (component old-pc pc fp)
662 (declare (type code-component component)
663 (ignore old-pc)
664 (type pc pc)
665 (type stack-pointer fp))
666 (labels ((grovel (remaining-blocks block-count-ptr)
667 (declare (type index remaining-blocks)
668 (type stack-pointer block-count-ptr))
669 (declare (values index stack-pointer))
670 (let ((block-count (eval-stack-ref block-count-ptr)))
671 (declare (type index block-count))
672 (if (= remaining-blocks 1)
673 (values block-count block-count-ptr)
674 (let ((src (- block-count-ptr block-count)))
675 (declare (type index src))
676 (multiple-value-bind
677 (values-above dst)
678 (grovel (1- remaining-blocks) (1- src))
679 (stack-copy dst src block-count)
680 (values (+ values-above block-count)
681 (+ dst block-count))))))))
682 (multiple-value-bind
683 (total-count end-ptr)
684 (grovel (pop-eval-stack) (1- (current-stack-pointer)))
685 (setf (eval-stack-ref end-ptr) total-count)
686 (setf (current-stack-pointer) (1+ end-ptr))))
687 (byte-interpret component pc fp))
688
689 (define-xop default-unknown-values (component old-pc pc fp)
690 (declare (type code-component component)
691 (ignore old-pc)
692 (type pc pc)
693 (type stack-pointer fp))
694 (let* ((desired (pop-eval-stack))
695 (supplied (pop-eval-stack))
696 (delta (- desired supplied)))
697 (declare (type index desired supplied)
698 (type fixnum delta))
699 (cond ((minusp delta)
700 (incf (current-stack-pointer) delta))
701 ((plusp delta)
702 (dotimes (i delta)
703 (push-eval-stack nil)))))
704 (byte-interpret component pc fp))
705
706 ;;; THROW -- XOP
707 ;;;
708 ;;; %THROW is compiled down into this xop. The stack contains the tag, the
709 ;;; values, and then a count of the values. We special case various small
710 ;;; numbers of values to keep from consing if we can help it.
711 ;;;
712 ;;; Basically, we just extract the values and the tag and then do a throw.
713 ;;; The native compiler will convert this throw into whatever is necessary
714 ;;; to throw, so we don't have to duplicate all that cruft.
715 ;;;
716 (define-xop throw (component old-pc pc fp)
717 (declare (type code-component component)
718 (type pc old-pc)
719 (ignore pc)
720 (type stack-pointer fp))
721 (let ((num-results (pop-eval-stack)))
722 (declare (type index num-results))
723 (case num-results
724 (0
725 (let ((tag (pop-eval-stack)))
726 (with-debugger-info (component old-pc fp)
727 (throw tag (values)))))
728 (1
729 (multiple-value-pop-eval-stack
730 (tag result)
731 (with-debugger-info (component old-pc fp)
732 (throw tag result))))
733 (2
734 (multiple-value-pop-eval-stack
735 (tag result0 result1)
736 (with-debugger-info (component old-pc fp)
737 (throw tag (values result0 result1)))))
738 (t
739 (let ((results nil))
740 (dotimes (i num-results)
741 (push (pop-eval-stack) results))
742 (let ((tag (pop-eval-stack)))
743 (with-debugger-info (component old-pc fp)
744 (throw tag (values-list results)))))))))
745
746 ;;; CATCH -- XOP
747 ;;;
748 ;;; This is used for both CATCHes and BLOCKs that are closed over. We
749 ;;; establish a catcher for the supplied tag (from the stack top), and
750 ;;; recursivly enter the byte interpreter. If the byte interpreter exits,
751 ;;; it must have been because of a BREAKUP (see below), so we branch (by
752 ;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
753 ;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
754 ;;; following the catch XOP.
755 ;;;
756 (define-xop catch (component old-pc pc fp)
757 (declare (type code-component component)
758 (ignore old-pc)
759 (type pc pc)
760 (type stack-pointer fp))
761 (let ((new-pc (block nil
762 (let ((results
763 (multiple-value-list
764 (catch (pop-eval-stack)
765 (return (byte-interpret component (+ pc 3) fp))))))
766 (let ((num-results 0))
767 (declare (type index num-results))
768 (dolist (result results)
769 (push-eval-stack result)
770 (incf num-results))
771 (push-eval-stack num-results))
772 (component-ref-24 component pc)))))
773 (byte-interpret component new-pc fp)))
774
775 ;;; BREAKUP -- XOP
776 ;;;
777 ;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the
778 ;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
779 ;;; TAGBODY will do the correct thing.
780 ;;;
781 (define-xop breakup (component old-pc pc fp)
782 (declare (ignore component old-pc fp)
783 (type pc pc))
784 pc)
785
786 ;;; RETURN-FROM -- XOP
787 ;;;
788 ;;; This is exactly like THROW, except that the tag is the last thing on
789 ;;; the stack instead of the first. This is used for RETURN-FROM (hence the
790 ;;; name).
791 ;;;
792 (define-xop return-from (component old-pc pc fp)
793 (declare (type code-component component)
794 (type pc old-pc)
795 (ignore pc)
796 (type stack-pointer fp))
797 (let ((tag (pop-eval-stack))
798 (num-results (pop-eval-stack)))
799 (declare (type index num-results))
800 (case num-results
801 (0
802 (with-debugger-info (component old-pc fp)
803 (throw tag (values))))
804 (1
805 (let ((value (pop-eval-stack)))
806 (with-debugger-info (component old-pc fp)
807 (throw tag value))))
808 (2
809 (multiple-value-pop-eval-stack
810 (result0 result1)
811 (with-debugger-info (component old-pc fp)
812 (throw tag (values result0 result1)))))
813 (t
814 (let ((results nil))
815 (dotimes (i num-results)
816 (push (pop-eval-stack) results))
817 (with-debugger-info (component old-pc fp)
818 (throw tag (values-list results))))))))
819
820 ;;; TAGBODY -- XOP
821 ;;;
822 ;;; Similar to CATCH, except for TAGBODY. One significant difference is that
823 ;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
824 ;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP
825 ;;; is used to blow out. When that happens, we just branch to the pc supplied
826 ;;; by BREAKUP.
827 ;;;
828 (define-xop tagbody (component old-pc pc fp)
829 (declare (type code-component component)
830 (ignore old-pc)
831 (type pc pc)
832 (type stack-pointer fp))
833 (let* ((tag (pop-eval-stack))
834 (new-pc (block nil
835 (loop
836 (setf pc
837 (catch tag
838 (return (byte-interpret component pc fp))))))))
839 (byte-interpret component new-pc fp)))
840
841 ;;; GO -- XOP
842 ;;;
843 ;;; Yup, you guessed it. This XOP implements GO. There are no values to
844 ;;; pass, so we don't have to mess with them, and multiple exits can all be
845 ;;; using the same tag so we have to pass the pc we want to go to.
846 ;;;
847 (define-xop go (component old-pc pc fp)
848 (declare (type code-component component)
849 (type pc old-pc pc)
850 (type stack-pointer fp))
851 (let ((tag (pop-eval-stack))
852 (new-pc (component-ref-24 component pc)))
853 (with-debugger-info (component old-pc fp)
854 (throw tag new-pc))))
855
856 ;;; UNWIND-PROTECT -- XOP
857 ;;;
858 ;;; Unwind-protects are handled significantly differently in the byte compiler
859 ;;; and the native compiler. Basically, we just use the native-compiler's
860 ;;; unwind-protect, and let it worry about continuing the unwind.
861 ;;;
862 (define-xop unwind-protect (component old-pc pc fp)
863 (declare (type code-component component)
864 (ignore old-pc)
865 (type pc pc)
866 (type stack-pointer fp))
867 (let ((new-pc nil))
868 (unwind-protect
869 (setf new-pc (byte-interpret component (+ pc 3) fp))
870 (unless new-pc
871 ;; The cleanup function expects 3 values to be one the stack, so
872 ;; we have to put something there.
873 (push-eval-stack nil)
874 (push-eval-stack nil)
875 (push-eval-stack nil)
876 ;; Now run the cleanup code.
877 (byte-interpret component (component-ref-24 component pc) fp)))
878 (byte-interpret component new-pc fp)))
879
880
881 (define-xop fdefn-function-or-lose (component old-pc pc fp)
882 (let* ((fdefn (pop-eval-stack))
883 (fun (fdefn-function fdefn)))
884 (declare (type fdefn fdefn))
885 (cond (fun
886 (push-eval-stack fun)
887 (byte-interpret component pc fp))
888 (t
889 (with-debugger-info (component old-pc fp)
890 (error 'undefined-function :name (fdefn-name fdefn)))))))
891
892
893 ;;; Used to insert placeholder arguments for unused arguments to local calls.
894 ;;;
895 (define-xop push-n-under (component old-pc pc fp)
896 (declare (ignore old-pc))
897 (with-extended-operand (component pc howmany new-pc)
898 (let ((val (pop-eval-stack)))
899 (allocate-eval-stack howmany)
900 (push-eval-stack val))
901 (byte-interpret component new-pc fp)))
902
903
904
905 ;;;; Type checking:
906
907 ;;;
908 ;;; These two hash tables map between type specifiers and type predicate
909 ;;; functions that test those types. They are initialized according to the
910 ;;; standard type predicates of the target system.
911 ;;;
912 (defvar *byte-type-predicates* (make-hash-table :test #'equal))
913 (defvar *byte-predicate-types* (make-hash-table :test #'eq))
914
915 (loop for (type predicate) in
916 '#.(loop for (type . predicate) in
917 (backend-type-predicates *target-backend*)
918 collect `(,(type-specifier type) ,predicate))
919 do
920 (let ((fun (fdefinition predicate)))
921 (setf (gethash type *byte-type-predicates*) fun)
922 (setf (gethash fun *byte-predicate-types*) type)))
923
924
925 ;;; LOAD-TYPE-PREDICATE -- Internal
926 ;;;
927 ;;; Called by the loader to convert a type specifier into a type predicate
928 ;;; (as used by the TYPE-CHECK XOP). If it is a structure type with a
929 ;;; predicate or has a predefined predicate, then return the predicate
930 ;;; function, otherwise return the CTYPE structure for the type.
931 ;;;
932 (defun load-type-predicate (desc)
933 (or (gethash desc *byte-type-predicates*)
934 (let ((type (specifier-type desc)))
935 (if (typep type 'kernel::structure-class)
936 (let ((info (layout-info (%class-layout type))))
937 (if (and info (eq (dd-type info) 'structure))
938 (let ((pred (dd-predicate info)))
939 (if (and pred (fboundp pred))
940 (fdefinition pred)
941 type))
942 type))
943 type))))
944
945
946 ;;; TYPE-CHECK -- Xop.
947 ;;;
948 ;;; Check the type of the value on the top of the stack. The type is
949 ;;; designated by an entry in the constants. If the value is a function, then
950 ;;; it is called as a type predicate. Otherwise, the value is a CTYPE object,
951 ;;; and we call %TYPEP on it.
952 ;;;
953 (define-xop type-check (component old-pc pc fp)
954 (declare (type code-component component)
955 (type pc old-pc pc)
956 (type stack-pointer fp))
957 (with-extended-operand (component pc operand new-pc)
958 (let ((value (eval-stack-ref (1- (current-stack-pointer))))
959 (type (code-header-ref component
960 (+ operand vm:code-constants-offset))))
961 (unless (if (functionp type)
962 (funcall type value)
963 (%typep value type))
964 (with-debugger-info (component old-pc fp)
965 (error 'type-error
966 :datum value
967 :expected-type (if (functionp type)
968 (gethash type *byte-predicate-types*)
969 (type-specifier type))))))
970
971 (byte-interpret component new-pc fp)))
972
973
974 ;;;; The byte-interpreter.
975
976
977 ;;; The various operations are encoded as follows.
978 ;;;
979 ;;; 0000xxxx push-local op
980 ;;; 0001xxxx push-arg op [push-local, but negative]
981 ;;; 0010xxxx push-constant op
982 ;;; 0011xxxx push-system-constant op
983 ;;; 0100xxxx push-int op
984 ;;; 0101xxxx push-neg-int op
985 ;;; 0110xxxx pop-local op
986 ;;; 0111xxxx pop-n op
987 ;;; 1000nxxx call op
988 ;;; 1001nxxx tail-call op
989 ;;; 1010nxxx multiple-call op
990 ;;; 10110xxx local-call
991 ;;; 10111xxx local-tail-call
992 ;;; 11000xxx local-multiple-call
993 ;;; 11001xxx return
994 ;;; 1101000r branch
995 ;;; 1101001r if-true
996 ;;; 1101010r if-false
997 ;;; 1101011r if-eq
998 ;;; 11011xxx Xop
999 ;;; 11100000
1000 ;;; to various inline functions.
1001 ;;; 11111111
1002 ;;;
1003 ;;; This encoding is rather hard wired into BYTE-INTERPRET due to the binary
1004 ;;; dispatch tree.
1005 ;;;
1006
1007 (declaim (start-block byte-interpret byte-interpret-byte
1008 invoke-xep invoke-local-entry-point))
1009
1010 (defvar *byte-trace* nil)
1011
1012 ;;; BYTE-INTERPRET -- Internal Interface.
1013 ;;;
1014 ;;; Main entry point to the byte interpreter.
1015 ;;;
1016 (defun byte-interpret (component pc fp)
1017 (declare (type code-component component)
1018 (type pc pc)
1019 (type stack-pointer fp))
1020 (byte-interpret-byte component pc fp (component-ref component pc)))
1021
1022 ;;; BYTE-INTERPRET-BYTE -- Internal.
1023 ;;;
1024 ;;; This is seperated from BYTE-INTERPRET so we can continue from a breakpoint
1025 ;;; without having to replace the breakpoint with the original instruction
1026 ;;; and arrange to somehow put the breakpoint back after executing the
1027 ;;; instruction. We just leave the breakpoint there, and calls this function
1028 ;;; with the byte the breakpoint displaced.
1029 ;;;
1030 (defun byte-interpret-byte (component pc fp byte)
1031 (declare (type code-component component)
1032 (type pc pc)
1033 (type stack-pointer fp)
1034 (type (unsigned-byte 8) byte)
1035 (optimize (speed 3) (safety 0)))
1036 #+nil
1037 (locally (declare (optimize (inhibit-warnings 3)))
1038 (when *byte-trace*
1039 (let ((*byte-trace* nil))
1040 (format *trace-output*
1041 "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%"
1042 pc fp (current-stack-pointer) byte
1043 (subseq eval::*eval-stack* fp (current-stack-pointer))))))
1044 (if (not (logbitp 7 byte))
1045 ;; Some stack operation. No matter what, we need the operand,
1046 ;; so compute it.
1047 (multiple-value-bind
1048 (operand new-pc)
1049 (let ((operand (logand byte #xf)))
1050 (if (= operand #xf)
1051 (let ((operand (component-ref component (1+ pc))))
1052 (if (= operand #xff)
1053 (values (component-ref-24 component (+ pc 2))
1054 (+ pc 5))
1055 (values operand (+ pc 2))))
1056 (values operand (1+ pc))))
1057 (if (not (logbitp 6 byte))
1058 (push-eval-stack (if (not (logbitp 5 byte))
1059 (if (not (logbitp 4 byte))
1060 (eval-stack-ref (+ fp operand))
1061 (eval-stack-ref (- fp operand 5)))
1062 (if (not (logbitp 4 byte))
1063 (code-header-ref
1064 component
1065 (+ operand vm:code-constants-offset))
1066 (svref system-constants operand))))
1067 (if (not (logbitp 5 byte))
1068 (push-eval-stack (if (not (logbitp 4 byte))
1069 operand
1070 (- (1+ operand))))
1071 (if (not (logbitp 4 byte))
1072 (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
1073 (if (zerop operand)
1074 (let ((operand (pop-eval-stack)))
1075 (declare (type index operand))
1076 (decf (current-stack-pointer) operand))
1077 (decf (current-stack-pointer) operand)))))
1078 (byte-interpret component new-pc fp))
1079 (if (not (logbitp 6 byte))
1080 ;; Some kind of call.
1081 (let ((args (let ((args (logand byte #x07)))
1082 (if (= args #x07)
1083 (pop-eval-stack)
1084 args))))
1085 (if (not (logbitp 5 byte))
1086 (let ((named (not (not (logbitp 3 byte)))))
1087 (if (not (logbitp 4 byte))
1088 ;; Call for single value.
1089 (do-call component pc (1+ pc) fp args named)
1090 ;; Tail call.
1091 (do-tail-call component pc fp args named)))
1092 (if (not (logbitp 4 byte))
1093 ;; Call for multiple-values.
1094 (do-call component pc (- (1+ pc)) fp args
1095 (not (not (logbitp 3 byte))))
1096 (if (not (logbitp 3 byte))
1097 ;; Local call
1098 (do-local-call component pc (+ pc 4) fp args)
1099 ;; Local tail-call
1100 (do-tail-local-call component pc fp args)))))
1101 (if (not (logbitp 5 byte))
1102 ;; local-multiple-call, Return, branch, or Xop.
1103 (if (not (logbitp 4 byte))
1104 ;; local-multiple-call or return.
1105 (if (not (logbitp 3 byte))
1106 ;; Local-multiple-call.
1107 (do-local-call component pc (- (+ pc 4)) fp
1108 (let ((args (logand byte #x07)))
1109 (if (= args #x07)
1110 (pop-eval-stack)
1111 args)))
1112 ;; Return.
1113 (let ((num-results
1114 (let ((num-results (logand byte #x7)))
1115 (if (= num-results 7)
1116 (pop-eval-stack)
1117 num-results))))
1118 (do-return fp num-results)))
1119 ;; Branch or Xop.
1120 (if (not (logbitp 3 byte))
1121 ;; Branch.
1122 (if (if (not (logbitp 2 byte))
1123 (if (not (logbitp 1 byte))
1124 t
1125 (pop-eval-stack))
1126 (if (not (logbitp 1 byte))
1127 (not (pop-eval-stack))
1128 (multiple-value-pop-eval-stack
1129 (val1 val2)
1130 (eq val1 val2))))
1131 ;; Branch taken.
1132 (byte-interpret
1133 component
1134 (if (not (logbitp 0 byte))
1135 (component-ref-24 component (1+ pc))
1136 (+ pc 2
1137 (component-ref-signed component (1+ pc))))
1138 fp)
1139 ;; Branch not taken.
1140 (byte-interpret component
1141 (if (not (logbitp 0 byte))
1142 (+ pc 4)
1143 (+ pc 2))
1144 fp))
1145 ;; Xop.
1146 (multiple-value-bind
1147 (sub-code new-pc)
1148 (let ((operand (logand byte #x7)))
1149 (if (= operand #x7)
1150 (values (component-ref component (+ pc 1))
1151 (+ pc 2))
1152 (values operand (1+ pc))))
1153 (funcall (the function (svref *byte-xops* sub-code))
1154 component pc new-pc fp))))
1155 ;; Random inline function.
1156 (progn
1157 (expand-into-inlines)
1158 (byte-interpret component (1+ pc) fp))))))
1159
1160 (defun do-local-call (component pc old-pc old-fp num-args)
1161 (declare (type pc pc)
1162 (type return-pc old-pc)
1163 (type stack-pointer old-fp)
1164 (type (integer 0 #.call-arguments-limit) num-args))
1165 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
1166 component old-pc
1167 (- (current-stack-pointer) num-args)
1168 old-fp))
1169
1170 (defun do-tail-local-call (component pc fp num-args)
1171 (declare (type code-component component) (type pc pc)
1172 (type stack-pointer fp)
1173 (type index num-args))
1174 (let ((old-fp (eval-stack-ref (- fp 1)))
1175 (old-sp (eval-stack-ref (- fp 2)))
1176 (old-pc (eval-stack-ref (- fp 3)))
1177 (old-component (eval-stack-ref (- fp 4)))
1178 (start-of-args (- (current-stack-pointer) num-args)))
1179 (stack-copy old-sp start-of-args num-args)
1180 (setf (current-stack-pointer) (+ old-sp num-args))
1181 (invoke-local-entry-point component (component-ref-24 component (1+ pc))
1182 old-component old-pc old-sp old-fp)))
1183
1184 (defun invoke-local-entry-point (component target old-component old-pc old-sp
1185 old-fp &optional closure-vars)
1186 (declare (type pc target)
1187 (type return-pc old-pc)
1188 (type stack-pointer old-sp old-fp)
1189 (type (or null simple-vector) closure-vars))
1190 (when closure-vars
1191 (iterate more ((index (1- (length closure-vars))))
1192 (unless (minusp index)
1193 (push-eval-stack (svref closure-vars index))
1194 (more (1- index)))))
1195 (push-eval-stack old-component)
1196 (push-eval-stack old-pc)
1197 (push-eval-stack old-sp)
1198 (push-eval-stack old-fp)
1199 (multiple-value-bind
1200 (stack-frame-size entry-pc)
1201 (let ((byte (component-ref component target)))
1202 (if (= byte 255)
1203 (values (component-ref-24 component (1+ target)) (+ target 4))
1204 (values (* byte 2) (1+ target))))
1205 (declare (type pc entry-pc))
1206 (let ((fp (current-stack-pointer)))
1207 (allocate-eval-stack stack-frame-size)
1208 (byte-interpret component entry-pc fp))))
1209
1210
1211 ;;; BYTE-APPLY -- Internal
1212 ;;;
1213 ;;; Call a function with some arguments popped off of the interpreter stack,
1214 ;;; and restore the SP to the specifier value.
1215 ;;;
1216 (defun byte-apply (function num-args restore-sp)
1217 (declare (function function) (type index num-args))
1218 (let ((start (- (current-stack-pointer) num-args)))
1219 (declare (type stack-pointer start))
1220 (macrolet ((frob ()
1221 `(case num-args
1222 ,@(loop for n below 8
1223 collect `(,n (call-1 ,n)))
1224 (t
1225 (let ((args ())
1226 (end (+ start num-args)))
1227 (declare (type stack-pointer end))
1228 (do ((i (1- end) (1- i)))
1229 ((< i start))
1230 (declare (fixnum i))
1231 (push (eval-stack-ref i) args))
1232 (setf (current-stack-pointer) restore-sp)
1233 (apply function args)))))
1234 (call-1 (n)
1235 (collect ((binds)
1236 (args))
1237 (dotimes (i n)
1238 (let ((dum (gensym)))
1239 (binds `(,dum (eval-stack-ref (+ start ,i))))
1240 (args dum)))
1241 `(let ,(binds)
1242 (setf (current-stack-pointer) restore-sp)
1243 (funcall function ,@(args))))))
1244 (frob))))
1245
1246
1247 (defun do-call (old-component call-pc ret-pc old-fp num-args named)
1248 (declare (type code-component old-component)
1249 (type pc call-pc)
1250 (type return-pc ret-pc)
1251 (type stack-pointer old-fp)
1252 (type (integer 0 #.call-arguments-limit) num-args)
1253 (type (member t nil) named))
1254 (let* ((old-sp (- (current-stack-pointer) num-args 1))
1255 (fun-or-fdefn (eval-stack-ref old-sp))
1256 (function (if named
1257 (or (fdefn-function fun-or-fdefn)
1258 (with-debugger-info (old-component call-pc old-fp)
1259 (error 'undefined-function
1260 :name (fdefn-name fun-or-fdefn))))
1261 fun-or-fdefn)))
1262 (declare (type stack-pointer old-sp)
1263 (type (or function fdefn) fun-or-fdefn)
1264 (type function function))
1265 (typecase function
1266 (byte-function
1267 (invoke-xep old-component ret-pc old-sp old-fp num-args function))
1268 (byte-closure
1269 (invoke-xep old-component ret-pc old-sp old-fp num-args
1270 (byte-closure-function function)
1271 (byte-closure-data function)))
1272 (t
1273 (cond ((minusp ret-pc)
1274 (let* ((ret-pc (- ret-pc))
1275 (results
1276 (multiple-value-list
1277 (with-debugger-info
1278 (old-component ret-pc old-fp)
1279 (byte-apply function num-args old-sp)))))
1280 (dolist (result results)
1281 (push-eval-stack result))
1282 (push-eval-stack (length results))
1283 (byte-interpret old-component ret-pc old-fp)))
1284 (t
1285 (push-eval-stack
1286 (with-debugger-info
1287 (old-component ret-pc old-fp)
1288 (byte-apply function num-args old-sp)))
1289 (byte-interpret old-component ret-pc old-fp)))))))
1290
1291
1292 (defun do-tail-call (component pc fp num-args named)
1293 (declare (type code-component component)
1294 (type pc pc)
1295 (type stack-pointer fp)
1296 (type (integer 0 #.call-arguments-limit) num-args)
1297 (type (member t nil) named))
1298 (let* ((start-of-args (- (current-stack-pointer) num-args))
1299 (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
1300 (function (if named
1301 (or (fdefn-function fun-or-fdefn)
1302 (with-debugger-info (component pc fp)
1303 (error 'undefined-function
1304 :name (fdefn-name fun-or-fdefn))))
1305 fun-or-fdefn))
1306 (old-fp (eval-stack-ref (- fp 1)))
1307 (old-sp (eval-stack-ref (- fp 2)))
1308 (old-pc (eval-stack-ref (- fp 3)))
1309 (old-component (eval-stack-ref (- fp 4))))
1310 (declare (type stack-pointer old-fp old-sp start-of-args)
1311 (type return-pc old-pc)
1312 (type (or fdefn function) fun-or-fdefn)
1313 (type function function))
1314 (typecase function
1315 (byte-function
1316 (stack-copy old-sp start-of-args num-args)
1317 (setf (current-stack-pointer) (+ old-sp num-args))
1318 (invoke-xep old-component old-pc old-sp old-fp num-args function))
1319 (byte-closure
1320 (stack-copy old-sp start-of-args num-args)
1321 (setf (current-stack-pointer) (+ old-sp num-args))
1322 (invoke-xep old-component old-pc old-sp old-fp num-args
1323 (byte-closure-function function)
1324 (byte-closure-data function)))
1325 (t
1326 ;; We are tail-calling native code.
1327 (cond ((null old-component)
1328 ;; We were called by native code.
1329 (byte-apply function num-args old-sp))
1330 ((minusp old-pc)
1331 ;; We were called for multiple values. So return multiple
1332 ;; values.
1333 (let* ((old-pc (- old-pc))
1334 (results
1335 (multiple-value-list
1336 (with-debugger-info
1337 (old-component old-pc old-fp)
1338 (byte-apply function num-args old-sp)))))
1339 (dolist (result results)
1340 (push-eval-stack result))
1341 (push-eval-stack (length results))
1342 (byte-interpret old-component old-pc old-fp)))
1343 (t
1344 ;; We were called for one value. So return one value.
1345 (push-eval-stack
1346 (with-debugger-info
1347 (old-component old-pc old-fp)
1348 (byte-apply function num-args old-sp)))
1349 (byte-interpret old-component old-pc old-fp)))))))
1350
1351 (defvar *byte-trace-calls* nil)
1352
1353 (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
1354 &optional closure-vars)
1355 (declare (type (or null code-component) old-component)
1356 (type index num-args)
1357 (type return-pc ret-pc)
1358 (type stack-pointer old-sp old-fp)
1359 (type byte-function xep)
1360 (type (or null simple-vector) closure-vars))
1361 (when *byte-trace-calls*
1362 (let ((*byte-trace-calls* nil)
1363 (*byte-trace* nil)
1364 (*print-level* debug:*debug-print-level*)
1365 (*print-length* debug:*debug-print-length*)
1366 (sp (current-stack-pointer)))
1367 (format *trace-output*
1368 "~&Invoke-XEP: ocode= ~S[~D]~% ~
1369 osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~
1370 Fun= ~S ~@[~S~]~% Args= ~S~%"
1371 old-component ret-pc old-sp old-fp num-args sp
1372 xep closure-vars (subseq *eval-stack* (- sp num-args) sp))
1373 (force-output *trace-output*)))
1374
1375 (let ((entry-point
1376 (cond
1377 ((typep xep 'simple-byte-function)
1378 (unless (eql (simple-byte-function-num-args xep) num-args)
1379 (with-debugger-info (old-component ret-pc old-fp)
1380 (simple-program-error (intl:gettext "Wrong number of arguments."))))
1381 (simple-byte-function-entry-point xep))
1382 (t
1383 (let ((min (hairy-byte-function-min-args xep))
1384 (max (hairy-byte-function-max-args xep)))
1385 (cond
1386 ((< num-args min)
1387 (with-debugger-info (old-component ret-pc old-fp)
1388 (simple-program-error (intl:gettext "Not enough arguments."))))
1389 ((<= num-args max)
1390 (nth (- num-args min) (hairy-byte-function-entry-points xep)))
1391 ((null (hairy-byte-function-more-args-entry-point xep))
1392 (with-debugger-info (old-component ret-pc old-fp)
1393 (simple-program-error (intl:gettext "Too many arguments."))))
1394 (t
1395 (let* ((more-args-supplied (- num-args max))
1396 (sp (current-stack-pointer))
1397 (more-args-start (- sp more-args-supplied))
1398 (restp (hairy-byte-function-rest-arg-p xep))
1399 (rest (and restp
1400 (do ((index (1- sp) (1- index))
1401 (result nil
1402 (cons (eval-stack-ref index)
1403 result)))
1404 ((< index more-args-start) result)
1405 (declare (fixnum index))))))
1406 (declare (type index more-args-supplied)
1407 (type stack-pointer more-args-start))
1408 (cond
1409 ((not (hairy-byte-function-keywords-p xep))
1410 (assert restp)
1411 (setf (current-stack-pointer) (1+ more-args-start))
1412 (setf (eval-stack-ref more-args-start) rest)
1413 (when (eq :more restp)
1414 (incf (current-stack-pointer))
1415 (setf (eval-stack-ref (1+ more-args-start))
1416 (length rest))))
1417 (t
1418 (unless (evenp more-args-supplied)
1419 (with-debugger-info (old-component ret-pc old-fp)
1420 (simple-program-error (intl:gettext "Odd number of keyword arguments."))))
1421 ;;
1422 ;; If there are keyword args we need to leave the
1423 ;; defaulted and supplied-p values where the more args
1424 ;; currently are. There might be more or fewer. And also,
1425 ;; we need to flatten the parsed args with the defaults
1426 ;; before we scan the keywords. So we copy all the more
1427 ;; args to a temporary area at the end of the stack.
1428 (let* ((num-more-args
1429 (hairy-byte-function-num-more-args xep))
1430 (new-sp (+ more-args-start num-more-args))
1431 (temp (max sp new-sp))
1432 (temp-sp (+ temp more-args-supplied))
1433 (keywords (hairy-byte-function-keywords xep)))
1434 (declare (type index temp)
1435 (type stack-pointer new-sp temp-sp))
1436 (allocate-eval-stack (- temp-sp sp))
1437 (stack-copy temp more-args-start more-args-supplied)
1438 (when restp
1439 (setf (eval-stack-ref more-args-start) rest)
1440 (incf more-args-start)
1441 (when (eq :more restp)
1442 (setf (eval-stack-ref (1+ more-args-start))
1443 (length rest))
1444 (incf more-args-start)))
1445 (let ((index more-args-start))
1446 (dolist (keyword keywords)
1447 (setf (eval-stack-ref index) (cadr keyword))
1448 (incf index)
1449 (when (caddr keyword)
1450 (setf (eval-stack-ref index) nil)
1451 (incf index))))
1452 (let ((index temp-sp)
1453 (allow (eq (hairy-byte-function-keywords-p xep)
1454 :allow-others))
1455 (bogus-key nil)
1456 (bogus-key-p nil))
1457 (declare (type fixnum index))
1458 (loop
1459 (decf index 2)
1460 (when (< index temp)
1461 (return))
1462 (let ((key (eval-stack-ref index))
1463 (value (eval-stack-ref (1+ index))))
1464 (if (eq key :allow-other-keys)
1465 (setf allow value)
1466 (let ((target more-args-start))
1467 (declare (type stack-pointer target))
1468 (dolist (keyword keywords
1469 (setf bogus-key key
1470 bogus-key-p t))
1471 (cond ((eq (car keyword) key)
1472 (setf (eval-stack-ref target) value)
1473 (when (caddr keyword)
1474 (setf (eval-stack-ref (1+ target))
1475 t))
1476 (return))
1477 ((caddr keyword)
1478 (incf target 2))
1479 (t
1480 (incf target))))))))
1481 (when (and bogus-key-p (not allow))
1482 (with-debugger-info (old-component ret-pc old-fp)
1483 (simple-program-error (intl:gettext "Unknown keyword: ~S")
1484 bogus-key))))
1485 (setf (current-stack-pointer) new-sp)))))
1486 (hairy-byte-function-more-args-entry-point xep))))))))
1487 (declare (type pc entry-point))
1488 (invoke-local-entry-point (byte-function-component xep) entry-point
1489 old-component ret-pc old-sp old-fp
1490 closure-vars)))
1491
1492 (defun do-return (fp num-results)
1493 (declare (type stack-pointer fp) (type index num-results))
1494 (let ((old-component (eval-stack-ref (- fp 4))))
1495 (typecase old-component
1496 (code-component
1497 ;; Returning to more byte-interpreted code.
1498 (do-local-return old-component fp num-results))
1499 (null
1500 ;; Returning to native code.
1501 (let ((old-sp (eval-stack-ref (- fp 2))))
1502 (case num-results
1503 (0
1504 (setf (current-stack-pointer) old-sp)
1505 (values))
1506 (1
1507 (let ((result (pop-eval-stack)))
1508 (setf (current-stack-pointer) old-sp)
1509 result))
1510 (t
1511 (let ((results nil))
1512 (dotimes (i num-results)
1513 (push (pop-eval-stack) results))
1514 (setf (current-stack-pointer) old-sp)
1515 (values-list results))))))
1516 (t
1517 ;; ### Function end breakpoint?
1518 (error (intl:gettext "function-end breakpoints not supported."))))))
1519
1520 (defun do-local-return (old-component fp num-results)
1521 (declare (type stack-pointer fp) (type index num-results))
1522 (let ((old-fp (eval-stack-ref (- fp 1)))
1523 (old-sp (eval-stack-ref (- fp 2)))
1524 (old-pc (eval-stack-ref (- fp 3))))
1525 (declare (type (signed-byte 25) old-pc))
1526 (if (plusp old-pc)
1527 ;; Wants single value.
1528 (let ((result (if (zerop num-results)
1529 nil
1530 (eval-stack-ref (- (current-stack-pointer)
1531 num-results)))))
1532 (setf (current-stack-pointer) old-sp)
1533 (push-eval-stack result)
1534 (byte-interpret old-component old-pc old-fp))
1535 ;; Wants multiple values.
1536 (progn
1537 (stack-copy old-sp (- (current-stack-pointer) num-results)
1538 num-results)
1539 (setf (current-stack-pointer) (+ old-sp num-results))
1540 (push-eval-stack num-results)
1541 (byte-interpret old-component (- old-pc) old-fp)))))
1542
1543 (declaim (end-block byte-interpret byte-interpret-byte invoke-xep))

  ViewVC Help
Powered by ViewVC 1.1.5